diff --git a/random/make-random-element-of.lsp b/random/make-random-element-of.lsp new file mode 100644 index 0000000000000000000000000000000000000000..dcbea8a92ca70f2668e6fd51c6c8b25ebf1cdb05 --- /dev/null +++ b/random/make-random-element-of.lsp @@ -0,0 +1,274 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Dec 28 20:28:03 2004 +;;;; Contains: Code to make random elements of types + +(in-package :cl-test) + +(defgeneric make-random-element-of (type) + (:documentation + "Create a random element of TYPE, or throw an error if it can't figure out how to do it.")) + +(defgeneric make-random-element-of-compound-type (type args &key &allow-other-keys) + (:documentation + "Create a random element of (TYPE . ARGS), or throw an error if it can't figure out how to do it.")) + +(defmethod make-random-element-of ((type cons)) + (make-random-element-of-compound-type (car type) (cdr type))) + +(defmethod make-random-element-of ((type (eql bit))) (random 2)) + +(defmethod make-random-element-of ((type (eql boolean))) + (random-from-seq #(nil t))) + +(defmethod make-random-elememt-of ((type (eql symbol))) + (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) + +(defmethod make-random-element-of ((type (eql unsigned-byte))) + (random-from-interval + (1+ (ash 1 (random *maximum-random-int-bits*))))) + +(defmethod make-random-elememt-of ((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 (eql rational))) + (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) + (n (random r)) + (d (loop for x = (random r) unless (zerop x) do (return x)))) + (if (coin) (/ n d) (- (/ n d))))) + +(defmethod make-random-element-of ((type (eql integer))) + (let* ((b (random *maximum-random-int-bits*)) + (x (ash 1 b))) + (rcase + (1 (+ x (make-random-element-of 'integer))) + (1 (- (make-random-element-of 'integer) x)) + (6 (random-from-interval (1+ x) (- x)))))) + +(defmethod make-random-element-of ((type (eql short-float))) + (make-random-element-of (list type))) + +(defmethod make-random-element-of ((type (eql single-float))) + (make-random-element-of (list type))) + +(defmethod make-random-element-of ((type (eql double-float))) + (make-random-element-of (list type))) + +(defmethod make-random-element-of ((type (eql long-float))) + (make-random-element-of (list type))) + +(defmethod make-random-element-of ((type (eql float))) + (make-random-element-of + (list (random-from-seq #'(short-float single-float double-float long-float))))) + +(defmethod make-random-element-of ((type (eql real))) + (make-random-element-of (random-from-seq #(integer rational float)))) + +(defmethod make-random-element-of ((type (eql ratio))) + (loop for x = (make-random-element-of 'rational) + unless (integerp x) return x)) + +(defmethod make-random-element-of ((type complex)) + (make-random-element-of '(complex real))) + +(defmethod make-random-element-of ((type fixnum)) + (make-random-element-of `(integer ,most-negative-fixnum ,most-positive-fixnum))) + +(defmethod make-random-element-of ((type bignum)) + (make-random-element-of `(or (integer * (,most-negative-fixnum)) + (integer (,most-positive-fixnum))))) + +(defmethod make-random-element-of ((type (eql number))) + (make-random-element-of (random-from-seq #(integer rational float complex)))) + +(defmethod make-random-element-of ((type (eql character))) + (rcase + (3 (random-from-seq +standard-chars+)) + (2 (let ((r (random 256))) + (or (code-char r) (make-random-element-of 'character)))) + (1 (let ((r (random #.(ash 1 16)))) + (or (code-char r) (make-random-element-of 'character)))) + (1 (let ((r (random #.(ash 1 24)))) + (or (code-char r) (make-random-element-of 'character)))))) + +(defmethod make-random-element-of ((type 'base-char)) + (random-from-seq +standard-chars+)) + +(defmethod make-random-element-of ((type 'standard-char)) + (random-from-seq +standard-chars+)) + +(defmethod make-random-element-of ((type (eql bit-vector))) + (make-random-vector 'bit '*)) + +(defmethod make-random-element-of ((type (eql simple-bit-vector))) + (make-random-vector 'bit '* :simple t)) + +(defmethod make-random-element-of ((type (eql vector))) + (make-random-vector '* '*)) + +(defmethod make-random-element-of ((type (eql simple-vector))) + (make-random-vector 't '* :simple t)) + +(defmethod make-random-elemnt-of ((type (eql array))) + (make-random-array '* '*)) + +(defmethod make-random-elemnt-of ((type (eql simple-array))) + (make-random-array '* '* :simple t)) + +(defmethod make-random-elememt-of ((type (eql string))) + (make-random-string '*)) + +(defmethod make-random-elememt-of ((type (eql simple-string))) + (make-random-string '* :simple t)) + +(defmethod make-random-element-of ((type (eql base-string))) + (make-random-vector 'base-char '*)) + +(defmethod make-random-element-of ((type (eql simple-base-string))) + (make-random-vector 'base-char '* :simple t)) + +(defmethod make-random-element-of ((type (eql cons))) + (make-random-element-of '(cons t t))) + +(defmethod make-random-element-of ((type (eql null))) nil) + +(defmethod make-random-elememt-of ((type (eql list))) + (let ((len (min (random 10) (random 10)))) + (loop repeat len collect (make-random-element-of-type t)))) + +(defmethod make-random-element-of ((type (eql sequence))) + (make-random-element-of '(or list vector))) + +;;;; + +(defun make-random-vector (length &key simple (element-type '*)) + (setq element-type (make-random-array-element-type element-type)) + (make-random-element-of `(,(if simple 'simple-vector 'vector) ,element-type ,length))) + +(defun make-random-array (dimensions &key simple (element-type '*)) + (setq element-type (make-random-array-element-type element-type)) + (make-random-element-of `(,(if simple 'simple-array 'array) ,element-type ,length))) + +(defun make-random-array-element-type (elememt-type) + (if (eq element-type '*) + (rcase + (1 'bit) + (1 `(unsigned-byte (1+ (random *maximum-random-int-bits*)))) + (1 `(signed-byte (1+ (random *maximum-random-int-bits*)))) + (2 (random-from-seq #(character base-char standard-char))) + ;; Put float, complex types here also + (4 t)) + element-type)) + +;;;; + +(defmethod make-random-element-of-compound-type ((type-op (eql or)) (args cons)) + (make-random-element-of (random-from-seq args))) + +(defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) + (loop for e = (make-random-element-of (car args)) + repeat 100 + when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) + return x + finally (error "Cannot generate a random element of ~A" + (cons 'and args)))) + +(defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) + (let ((lo (let ((lo (car args))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (cadr 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))))) + +(defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) + (make-random-element-of-float-type type args)) + +(defmethod make-random-element-of-compound-type ((type-op (eql single-float)) (args t)) + (make-random-element-of-float-type type args)) + +(defmethod make-random-element-of-compound-type ((type-op (eql double-float)) (args t)) + (make-random-element-of-float-type type args)) + +(defmethod make-random-element-of-compound-type ((type-op (eql long-float)) (args t)) + (make-random-element-of-float-type type args)) + +(defun make-random-element-of-float-type (type-op args) + (let ((lo (car args)) + (hi (cadr args)) + 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-compound-type ((type-op (eql mod)) (args cons)) + (let ((modulus (car args))) + (assert (integerp modulus)) + (assert (plusp modulus)) + (make-random-element-of `(integer 0 (,modulus))))) + +(defmethod make-random-element-of-compound-type ((type-op (eql unsigned-byte)) (args t)) + (if (null args) + (make-random-element-of '(integer 0 *)) + (let ((bits (car args))) + (if (eq bits'*) + (make-random-element-of '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) + +(defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) + (assert (null (cdr args))) + (car args)) + +(defmethod make-random-element-of-compound-type ((type-op (eql member)) (args cons)) + (random-from-seq args)) + + + diff --git a/random/random-class.lsp b/random/random-class.lsp new file mode 100644 index 0000000000000000000000000000000000000000..1453fdd222d03c80d8559212fbc90d643cb74143 --- /dev/null +++ b/random/random-class.lsp @@ -0,0 +1,9 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 10 07:13:47 2004 +;;;; Contains: Randomized tests on classes + +(in-package :cl-test) + +(compile-and-load "random-class-aux.lsp") + diff --git a/random/random-int-form.lsp b/random/random-int-form.lsp new file mode 100644 index 0000000000000000000000000000000000000000..7c18b164891ab851edb6135051f5f5e95d4e584d --- /dev/null +++ b/random/random-int-form.lsp @@ -0,0 +1,2971 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Wed Sep 10 18:03:52 2003 +;;;; Contains: Simple randon form generator/tester + +(in-package :cl-test) + +(compile-and-load "random-aux.lsp") + +;;; +;;; This file contains a routine for generating random legal Common Lisp functions +;;; for differential testing. +;;; +;;; To run the random tests by themselves, start a lisp in the ansi-tests directory +;;; and do the following: +;;; (load "gclload1.lsp") +;;; (compile-and-load "random-int-form.lsp") +;;; (in-package :cl-test) +;;; (let ((*random-state* (make-random-state t))) +;;; (test-random-integer-forms 100 4 10000)) ;; or other parameters +;;; +;;; If a test breaks during testing the variables *optimized-fn-src*, +;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source +;;; of the optimized/unoptimized lambda forms being compiled, and the arguments +;;; on which they are called. +;;; +;;; If a difference is found between optimized/unoptimized functions the forms, +;;; values, and results are collected. A list of all these discrepancies is returned +;;; after testing finishes (assuming nothing breaks). +;;; +;;; The variable *compile-unoptimized-form* controls whether the low optimization +;;; form is compiled, or if a form funcalling it is EVALed. The latter is often +;;; faster, and may find more problems since an interpreter and compiler may evaluate +;;; forms in very different ways. +;;; +;;; The rctest/ subdirectory contains fragments of a more OO random form generator +;;; that will eventually replace this preliminary effort. +;;; +;;; The file misc.lsp contains tests that were mostly for bugs found by this +;;; random tester in various Common Lisp implementations. +;;; + +(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* + *opt-result* *unopt-result* $x $y $z + *compile-unoptimized-form* + *make-random-integer-form-cdf*)) + +;;; Little functions used to run collected tests. +;;; (f i) runs the ith collected optimized test +;;; (g i) runs the ith collected unoptimized test +;;; (p i) prints the ith test (forms, input values, and other information) + +(defun f (i) (let ((plist (elt $y i))) + (apply (compile nil (getf plist :optimized-lambda-form)) + (getf plist :vals)))) + +(defun g (i) (let ((plist (elt $y i))) + (if *compile-unoptimized-form* + (apply (compile nil (getf plist :unoptimized-lambda-form)) + (getf plist :vals)) + (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) + (getf plist :vals))))) + +(defun p (i) (write (elt $y i) :pretty t :escape t) (values)) + +(defun load-failures (&key (pathname "failures.lsp")) + (length (setq $y (with-open-file (s pathname :direction :input) + (loop for x = (read s nil) + while x collect x))))) + +(defun tn (n &optional (size 100)) + (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) + +(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) + +(defparameter *random-special-vars* + #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)) + +(defparameter *loop-random-int-form-period* 2000) + +(defmacro cl-handler-bind (&rest args) + `(cl:handler-bind ,@args)) + +(defmacro cl-handler-case (&rest args) + `(cl:handler-case ,@args)) + +(eval-when + (:compile-toplevel :load-toplevel :execute) + (defun cumulate (vec) + (loop for i from 1 below (length vec) + do (incf (aref vec i) (aref vec (1- i)))) + vec)) + +(defparameter *default-make-random-integer-form-cdf* + (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1 + #-allegro 5 5 5 #-(or gcl ecl armedbear) 2 + 2 #-(or cmu allegro poplog) 5 4 30 + 4 20 3 2 2 1 1 5 30 #-poplog 5 + #-(or allegro poplog) 10 + 50 4 4 10 20 10 10 3 + 20 5 #-(or armedbear) 20 + 2 2 2)))) + +(defparameter *make-random-integer-form-cdf* + (copy-seq *default-make-random-integer-form-cdf*)) + +(eval-when + (:compile-toplevel :load-toplevel :execute) + (defmacro with-random-integer-form-params (&body forms) + (let ((len (gensym "LEN")) + (vec (gensym "VEC"))) + `(let* ((,len (length *default-make-random-integer-form-cdf*)) + (,vec (make-array ,len))) + (loop for i from 0 below ,len do (setf (aref ,vec i) + (1+ (min (random 100) + (random 100))))) + (setq ,vec (cumulate ,vec)) + (let ((*make-random-integer-form-cdf* ,vec)) + ,@forms))))) + +;;; Run the random tester, collecting failures into the special +;;; variable $y. + +(defun loop-random-int-forms (&optional (size 200) (nvars 3)) + (unless (boundp '$x) (setq $x nil)) + (unless (boundp '$y) (setq $y nil)) + (loop + for i from 1 + do + (format t "~6D | " i) + (finish-output *standard-output*) + (let ((x (test-random-integer-forms + size nvars *loop-random-int-form-period* + :index (* (1- i) *loop-random-int-form-period*)))) + (when x + (setq $x (append $x x)) + (setq x (prune-results x)) + (terpri) (print x) (finish-output *standard-output*) + (setq $y (append $y x))) + (terpri)))) + +(defvar *random-int-form-blocks* nil) +(defvar *random-int-form-catch-tags* nil) +(defvar *go-tags* nil) + +(defvar *random-vals-list-bound* 10) + +(defvar *max-compile-time* 0) +(defvar *max-compile-term* nil) + +(defvar *print-immediately* nil) + +(defvar *compile-unoptimized-form* + #+(or allegro sbcl) t + #-(or allegro sbcl) nil) + +(declaim (special *vars*)) + +(defstruct var-desc + (name nil :type symbol) + (type t)) + +(defun test-random-integer-forms + (size nvars n + &key ((:random-state *random-state*) (make-random-state t)) + (file-prefix "b") + (index 0) + (random-size nil) + (random-nvars nil) + ) + + "Generate random integer forms of size SIZE with NVARS variables. + Do this N times, returning all those on which a discrepancy + is found between optimized and nonoptimize, notinlined code." + + (assert (integerp nvars)) + (assert (<= 1 nvars 26)) + (assert (and (integerp n) (plusp n))) + (assert (and (integerp n) (plusp size))) + + (loop for i from 1 to n + do (when (= (mod i 100) 0) + ;; #+sbcl (print "Do gc...") + ;; #+sbcl (sb-ext::gc :full t) + ;; #+lispworks-personal-edition (cl-user::normal-gc) + (prin1 i) (princ " ") (finish-output *standard-output*)) + nconc (let ((result (test-random-integer-form + (if random-size (1+ (random size)) size) + (if random-nvars (1+ (random nvars)) nvars) + :index (+ index i) + :file-prefix file-prefix))) + (when result + (let ((*print-readably* nil)) + (format t "~%~A~%" (format nil "~S" (car result))) + (finish-output *standard-output*))) + result))) + +(defun test-random-integer-form + (size nvars &key (index 0) (file-prefix "b")) + (let* ((vars (subseq '(a b c d e f g h i j k l m + n o p q r s u v w x y z) 0 nvars)) + (var-ranges (mapcar #'make-random-integer-range vars)) + (var-types (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (assert (>= hi lo)) + `(integer ,lo ,hi))) + var-ranges)) + (form (let ((*vars* (loop for v in vars + for tp in var-types + collect (make-var-desc :name v + :type tp))) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil) + ) + (with-random-integer-form-params + (make-random-integer-form (1+ (random size)))))) + (vals-list + (loop repeat *random-vals-list-bound* + collect + (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (random-from-interval (1+ hi) lo))) + var-ranges))) + (opt-decls-1 (make-random-optimize-settings)) + (opt-decls-2 (make-random-optimize-settings))) + (when *print-immediately* + (with-open-file + (s (format nil "~A~A.lsp" file-prefix index) + :direction :output :if-exists :error) + (print `(defparameter *x* + '(:vars ,vars + :var-types ,var-types + :vals-list ,vals-list + :decls1 ,opt-decls-1 + :decls2 ,opt-decls-2 + :form ,form)) + s) + (print '(load "c.lsp") s) + (finish-output s)) + ;; (cl-user::gc) + ;; (make-list 1000000) + ) + (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) + +(defun make-random-optimize-settings () + (loop for settings = (list* + (list 'speed (random 4)) + #+sbcl '(sb-c:insert-step-conditions 0) + (loop for s in '(space safety debug compilation-speed) + for n = (random 4) + collect (list s n))) + while + #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) + #-allegro nil + finally (return (random-permute settings)))) + +(defun fn-symbols-in-form (form) + "Return a list of the distinct standardized lisp function + symbols occuring ing FORM. These are used to generate a NOTINLINE + declaration for the unoptimized form." + (intersection + (remove-duplicates (fn-symbols-in-form* form) :test #'eq) + *cl-function-or-accessor-symbols*)) + +(defun fn-symbols-in-form* (form) + (when (consp form) + (if (symbolp (car form)) + (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) + (mapcan #'fn-symbols-in-form* form)))) + +(defun fn-arg-name (fn-name arg-index) + (intern (concatenate 'string + (subseq (symbol-name fn-name) 1) + (format nil "-~D" arg-index)) + (symbol-package fn-name))) + +(declaim (special *flet-names*)) +(defparameter *flet-names* nil) + + + +(defun random-var-desc () + (loop + (let* ((pos (random (length *vars*))) + (desc (elt *vars* pos))) + (when (= pos (position (var-desc-name desc) (the list *vars*) + :key #'var-desc-name)) + (return desc))))) + +(defun is-zero-rank-integer-array-type (type) + "This function was introduced because of a bug in ACL 6.2" + ; (subtypep type '(array integer 0)) + (and (consp type) + (eq (car type) 'array) + (cddr type) + (or (eq (cadr type) '*) + (subtypep (cadr type) 'integer)) + (or (eql (caddr type) 0) + (null (caddr type))))) + +(defun make-random-integer-form (size) + "Generate a random legal lisp form of size SIZE (roughly)." + + (if (<= size 1) + ;; Leaf node -- generate a variable, constant, or flet function call + (loop + when + (rcase + (10 (make-random-integer)) + (9 (if *vars* + (let* ((desc (random-var-desc)) + (type (var-desc-type desc)) + (name (var-desc-name desc))) + (cond + ((subtypep type 'integer) name) + (; (subtypep type '(array integer 0)) + (is-zero-rank-integer-array-type type) + `(aref ,name)) + ((subtypep type '(cons integer integer)) + (rcase (1 `(car ,name)) + (1 `(cdr ,name)))) + (t nil))) + nil)) + (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) + (2 (if *flet-names* + (let* ((flet-entry (random-from-seq *flet-names*)) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + (args (loop repeat nargs + collect (make-random-integer-form 1)))) + `(,flet-name ,@args)) + nil))) + return it) + ;; (> size 1) + (rselect *make-random-integer-form-cdf* + + ;; flet call + (make-random-integer-flet-call-form size) + (make-random-aref-form size) + ;; Unary ops + (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate + rational rationalize + numerator denominator + identity progn floor + ;; #-(or armedbear) + ignore-errors + cl:handler-case + restart-case + ceiling truncate round realpart imagpart + integer-length logcount values + locally)))) + `(,op ,(make-random-integer-form (1- size)))) + + (make-random-integer-unwind-protect-form size) + (make-random-integer-mapping-form size) + + ;; prog1, multiple-value-prog1 + (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args)) + + ;; prog2 + (let* ((nforms (random 4)) + (sizes (random-partition (1- size) (+ nforms 2))) + (args (mapcar #'make-random-integer-form sizes))) + `(prog2 ,@args)) + + `(isqrt (abs ,(make-random-integer-form (- size 2)))) + + `(the integer ,(make-random-integer-form (1- size))) + + `(cl:handler-bind nil ,(make-random-integer-form (1- size))) + `(restart-bind nil ,(make-random-integer-form (1- size))) + #-armedbear + `(macrolet () ,(make-random-integer-form (1- size))) + #-armedbear + `(symbol-macrolet () ,(make-random-integer-form (1- size))) + + ;; dotimes + #-allegro + (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) + (count (random 4)) + (sizes (random-partition (1- size) 2)) + (body (let ((*vars* (cons (make-var-desc :name var :type nil) + *vars*))) + (make-random-integer-form (first sizes)))) + (ret-form (make-random-integer-form (second sizes)))) + (unless (consp body) (setq body `(progn ,body))) + `(dotimes (,var ,count ,ret-form) ,body)) + + ;; loop + (make-random-loop-form (1- size)) + + (make-random-count-form size) + + #-(or gcl ecl armedbear) + ;; load-time-value + (let ((arg (let ((*flet-names* nil) + (*vars* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil)) + (make-random-integer-form (1- size))))) + (rcase + (4 `(load-time-value ,arg t)) + (2 `(load-time-value ,arg)) + (2 `(load-time-value ,arg nil)))) + + ;; eval + (make-random-integer-eval-form size) + + #-(or cmu allegro poplog) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(ash ,(make-random-integer-form s1) + (min ,(random 100) + ,(make-random-integer-form s2)))) + + ;; binary floor, ceiling, truncate, round + (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) + (op2 (random-from-seq #(max min)))) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(,op ,(make-random-integer-form s1) + (,op2 ,(if (eq op2 'max) + (1+ (random 100)) + (- (1+ (random 100)))) + ,(make-random-integer-form s2))))) + + ;; Binary op + (let* ((op (random-from-seq + '(+ - * logand min max gcd + lcm + #-:allegro + logandc1 + logandc2 logeqv logior lognand lognor + #-:allegro + logorc1 + logorc2 + logxor + )))) + (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(,op ,e1 ,e2)))) + + ;; boole + (let* ((op (random-from-seq + #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 + boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand + boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) + (destructuring-bind (leftsize rightsize) + (random-partition (- size 2) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(boole ,op ,e1 ,e2)))) + + ;; n-ary ops + (let* ((op (random-from-seq #(+ - * logand min max + logior values lcm gcd logxor))) + (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40))))) + (nargs (1+ (min (random nmax) (random nmax)))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args)) + + ;; expt + `(expt ,(make-random-integer-form (1- size)) ,(random 3)) + + ;; coerce + `(coerce ,(make-random-integer-form (1- size)) 'integer) + + ;; complex (degenerate case) + `(complex ,(make-random-integer-form (1- size)) 0) + + ;; quotient (degenerate cases) + `(/ ,(make-random-integer-form (1- size)) 1) + `(/ ,(make-random-integer-form (1- size)) -1) + + ;; tagbody + (make-random-tagbody-and-progn size) + + ;; conditionals + (let* ((cond-size (random (max 1 (floor size 2)))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-integer-form then-size)) + (else-part (make-random-integer-form else-size))) + `(if ,pred ,then-part ,else-part)) + #-poplog + (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) + `(,(random-from-seq '(deposit-field dpb)) + ,(make-random-integer-form s1) + ,(make-random-byte-spec-form s2) + ,(make-random-integer-form s3))) + + #-(or allegro poplog) + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + `(,(random-from-seq '(ldb mask-field)) + ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2))) + + (make-random-integer-binding-form size) + + ;; progv + (make-random-integer-progv-form size) + + `(let () ,(make-random-integer-form (1- size))) + + (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) + (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) + `(block ,name ,(make-random-integer-form (1- size)))) + + (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) + (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) + `(catch ,tag ,(make-random-integer-form (1- size)))) + + ;; setq and similar + (make-random-integer-setq-form size) + + (make-random-integer-case-form size) + + (if *random-int-form-blocks* + (let ((name (random-from-seq *random-int-form-blocks*)) + (form (make-random-integer-form (1- size)))) + `(return-from ,name ,form)) + ;; No blocks -- try again + (make-random-integer-form size)) + + (if *random-int-form-catch-tags* + (let ((tag (random-from-seq *random-int-form-catch-tags*)) + (form (make-random-integer-form (1- size)))) + `(throw ,tag ,form)) + ;; No catch tags -- try again + (make-random-integer-form size)) + + (if *random-int-form-blocks* + (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) + (let ((name (random-from-seq *random-int-form-blocks*)) + (pred (make-random-pred-form s1)) + (then (make-random-integer-form s2)) + (else (make-random-integer-form s3))) + `(if ,pred (return-from ,name ,then) ,else))) + ;; No blocks -- try again + (make-random-integer-form size)) + + #-(or armedbear) + (make-random-flet-form size) + + (let* ((nbits (1+ (min (random 20) (random 20)))) + (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) + (op (random-from-seq #(bit sbit)))) + `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits)))))) + + (let* ((nvals (1+ (min (random 20) (random 20)))) + (lim (ash 1 (+ 3 (random 40)))) + (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) + (op (random-from-seq #(aref svref elt)))) + `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) + + (let* ((nvals (1+ (min (random 20) (random 20)))) + (lim (ash 1 (+ 3 (random 40)))) + (vals (loop repeat nvals collect (random lim))) + (op 'elt)) + `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) + + ))) + +(defun make-random-aref-form (size) + (or + (when *vars* + (let* ((desc (random-var-desc)) + (type (var-desc-type desc)) + (name (var-desc-name desc))) + (cond + ((null type) nil) + ((subtypep type '(array integer (*))) + `(aref ,name (min ,(1- (first (third type))) + (max 0 ,(make-random-integer-form (- size 2)))))) + ((subtypep type '(array integer (* *))) + (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) + `(aref ,name + (min ,(1- (first (third type))) + (max 0 ,(make-random-integer-form s1))) + (min ,(1- (second (third type))) + (max 0 ,(make-random-integer-form s2)))))) + (t nil)))) + (make-random-integer-form size))) + +(defun make-random-count-form (size) + (destructuring-bind (s1 s2) + (random-partition (1- size) 2) + (let ((arg1 (make-random-integer-form s1)) + (arg2-args (loop repeat s2 collect (make-random-integer)))) + (let ((op 'count) + (test (random-from-seq #(eql = /= < > <= >=))) + (arg2 (rcase + (1 (make-array (list s2) :initial-contents arg2-args)) + (1 + (let* ((mask (1- (ash 1 (1+ (random 32)))))) + (make-array (list s2) + :initial-contents + (mapcar #'(lambda (x) (logand x mask)) arg2-args) + :element-type `(integer 0 ,mask)))) + (1 `(quote ,arg2-args))))) + `(,op ,arg1 ,arg2 ,@(rcase + (2 nil) + (1 (list :test `(quote ,test))) + (1 (list :test-not `(quote ,test))))))))) + +(defun make-random-integer-flet-call-form (size) + (if *flet-names* + (let* ((flet-entry (random-from-seq *flet-names*)) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + ) + (cond + ((> nargs 0) + (let* ((arg-sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form arg-sizes))) + (rcase + (1 `(,flet-name ,@args)) + (1 `(multiple-value-call #',flet-name (values ,@args))) + (1 `(funcall (function ,flet-name) ,@args)) + (1 (let ((r (random (1+ (length args))))) + `(apply (function ,flet-name) + ,@(subseq args 0 r) + (list ,@(subseq args r)))))))) + (t (make-random-integer-form size)))) + (make-random-integer-form size))) + +(defun make-random-integer-unwind-protect-form (size) + (let* ((op 'unwind-protect) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (arg (make-random-integer-form (first sizes))) + (unwind-forms + ;; We have to be careful not to generate code that will + ;; illegally transfer control to a dead location + (let ((*flet-names* nil) + (*go-tags* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil)) + (mapcar #'make-random-integer-form (rest sizes))))) + `(,op ,arg ,@unwind-forms))) + +(defun make-random-integer-eval-form (size) + (flet ((%arg (size) + (let ((*flet-names* nil) + (*vars* (remove-if-not #'(lambda (s) + (find (var-desc-name s) + *random-special-vars*)) + *vars*)) + (*random-int-form-blocks* nil) + (*go-tags* nil)) + (make-random-integer-form size)))) + (rcase + (2 `(eval ',(%arg (1- size)))) + (2 (let* ((nargs (1+ (random 4))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'%arg sizes))) + `(eval (values ,@args)))) + ))) + +(defun make-random-type-for-var (var e1) + (let (desc) + (values + (cond + ((and (find var *random-special-vars*) + (setq desc (find var *vars* :key #'var-desc-name))) + (var-desc-type desc)) + (t (rcase + (4 '(integer * *)) + (1 (setq e1 `(make-array nil :initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + '(array integer nil)) + (1 (let ((size (1+ (random 10)))) + (setq e1 `(make-array '(,size):initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + `(array integer (,size)))) + #| + (1 (let ((size1 (1+ (random 10))) + (size2 (1+ (random 10)))) + (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + `(array integer (,size1 ,size2)))) + |# + (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) + '(cons integer integer)) + (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) + '(cons integer integer))))) + e1))) + +(defun random2 (n) + (min (random n) (random n))) + +(defun random-from-seq2 (seq) + (elt seq (random2 (length seq)))) + +(defun make-random-integer-binding-form (size) + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + (let* ((var (random-from-seq2 (rcase + (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) + #-ecl (2 *random-special-vars*) + ))) + (e1 (make-random-integer-form s1)) + (type (multiple-value-bind (type2 e) + (make-random-type-for-var var e1) + (setq e1 e) + type2)) + (e2 (let ((*vars* (cons (make-var-desc :name var :type type) + *vars*))) + (make-random-integer-form s2))) + (op (random-from-seq #(let let*)))) + ;; for now, avoid shadowing + (if (member var *vars* :key #'var-desc-name) + (make-random-integer-form size) + (rcase + (8 `(,op ((,var ,e1)) + ,@(rcase (1 `((declare (dynamic-extent ,var)))) + (3 nil)) + ,e2)) + (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) + +(defun make-random-integer-progv-form (size) + (let* ((num-vars (random 4)) + (possible-vars *random-special-vars*) + (vars nil)) + (loop repeat num-vars + do (loop for r = (elt possible-vars (random (length possible-vars))) + while (member r vars) + finally (push r vars))) + (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) + (and desc (not (subtypep (var-desc-type desc) 'integer))))) + vars) + num-vars (length vars)) + (if (null vars) + `(progv nil nil ,(make-random-integer-form (1- size))) + (destructuring-bind (s1 s2) (random-partition (1- size) 2) + (let* ((var-sizes (random-partition s1 num-vars)) + (var-forms (mapcar #'make-random-integer-form var-sizes)) + (*vars* (append (loop for v in vars collect + (make-var-desc :name v :type '(integer * *))) + *vars*)) + (body-form (make-random-integer-form s2))) + `(progv ',vars (list ,@var-forms) ,body-form)))))) + +(defun make-random-integer-mapping-form (size) + ;; reduce + (let ((keyargs nil) + (nargs (1+ (random (min 10 (max 1 size))))) + (sequence-op (random-from-seq '(vector list)))) + (when (coin 2) (setq keyargs '(:from-end t))) + (cond + ((coin 2) + (let ((start (random nargs))) + (setq keyargs `(:start ,start ,@keyargs)) + (when (coin 2) + (let ((end (+ start 1 (random (- nargs start))))) + (setq keyargs `(:end ,end ,@keyargs)))))) + (t + (when (coin 2) + (let ((end (1+ (random nargs)))) + (setq keyargs `(:end ,end ,@keyargs)))))) + (rcase + (1 + (let ((sizes (random-partition (1- size) nargs)) + (op (random-from-seq #(+ - * logand logxor logior max min)))) + `(reduce ,(rcase (1 `(function ,op)) + (1 `(quote ,op))) + (,sequence-op + ,@(mapcar #'make-random-integer-form sizes)) + ,@keyargs))) + #-(or armedbear) + (1 + (destructuring-bind (size1 size2) (random-partition (1- size) 2) + (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) + (var1 (random-from-seq vars)) + (var2 (random-from-seq (remove var1 vars))) + (form (let ((*vars* (list* + (make-var-desc :name var1 :type '(integer * *)) + (make-var-desc :name var2 :type '(integer * *)) + *vars*))) + (make-random-integer-form size1))) + (sizes (random-partition size2 nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(reduce (function (lambda (,var1 ,var2) ,form)) + (,sequence-op ,@args) + ,@keyargs))))))) + +(defun make-random-integer-setq-form (size) + (if *vars* + (let* ((vdesc (random-from-seq *vars*)) + (var (var-desc-name vdesc)) + (type (var-desc-type vdesc)) + (op (random-from-seq #(setq setf shiftf)))) + (cond + ((subtypep '(integer * *) type) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (rcase + (1 (when (find var *random-special-vars*) + (setq op (random-from-seq #(setf shiftf)) + var `(symbol-value ',var)))) + (1 (setq op 'multiple-value-setq) + (setq var (list var))) + (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) + `(,op ,var ,(make-random-integer-form (1- size)))) + ((and (consp type) + (eq (car type) 'integer) + (integerp (second type)) + (integerp (third type))) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (rcase + (1 (when (find var *random-special-vars*) + (setq op (random-from-seq #(setf shiftf)) + var `(symbol-value ',var)))) + (1 (setq op 'multiple-value-setq) + (setq var (list var))) + (5 nil)) + `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) + ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) + ((and type (subtypep type '(array integer (*)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) + `(,op (aref ,var (min ,(1- (first (third type))) + (max 0 + ,(make-random-integer-form s1)))) + ,(make-random-integer-form s2)))) + ((and type (subtypep type '(array integer (* *)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) + `(,op (aref ,var + (min ,(1- (first (third type))) + (max 0 + ,(make-random-integer-form s1))) + (min ,(1- (second (third type))) + (max 0 + ,(make-random-integer-form s2)))) + ,(make-random-integer-form s3)))) + ;; Abort -- can't assign + (t (make-random-integer-form size)))) + (make-random-integer-form size))) + + +(defun make-random-integer-case-form (size) + (let ((ncases (1+ (random 10)))) + (if (< (+ size size) (+ ncases 2)) + ;; Too small, give up + (make-random-integer-form size) + (let* ((sizes (random-partition (1- size) (+ ncases 2))) + (bound (ash 1 (+ 2 (random 16)))) + (lower-bound (if (coin 3) 0 (- bound))) + (upper-bound (if (and (< lower-bound 0) (coin 3)) + 1 + (1+ bound))) + (cases + (loop + for case-size in (cddr sizes) + for vals = (loop repeat (1+ (min (random 10) (random 10))) + collect (random-from-interval + upper-bound lower-bound)) + for result = (make-random-integer-form case-size) + repeat ncases + collect `(,vals ,result))) + (expr (make-random-integer-form (first sizes)))) + `(case ,expr + ,@cases + (t ,(make-random-integer-form (second sizes)))))))) + +(defun make-random-flet-form (size) + "Generate random flet, labels forms, for now with no arguments + and a single binding per form." + (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 + %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) + (if (assoc fname *flet-names*) + ;; Fail if the name is in use + (make-random-integer-form size) + (let* ((op (random-from-seq #(flet labels))) + (minargs (random 4)) + (maxargs #+:allegro minargs + #-:allegro + (rcase + (1 minargs) + (1 (+ minargs (random 4))))) + (keyarg-p (coin 2)) + (keyarg-n (if keyarg-p (random 3) 0)) + (arg-names (loop for i from 1 to maxargs + collect (fn-arg-name fname i))) + (key-arg-names (loop for i from 1 to keyarg-n + collect (intern (format nil "KEY~A" i) + (find-package "CL-TEST")))) + (allow-other-keys (and keyarg-p (coin 3))) + ) + (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) + (s1 (car sizes)) + (s2 (cadr sizes)) + (opt-sizes (cddr sizes))) + (let* ((form1 + ;; Allow return-from of the flet/labels function + (let ((*random-int-form-blocks* + (cons fname *random-int-form-blocks*)) + (*vars* (nconc (loop for var in (append arg-names key-arg-names) + collect (make-var-desc :name var + :type '(integer * *))) + *vars*))) + (make-random-integer-form s1))) + (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) + *flet-names*))) + (make-random-integer-form s2))) + (opt-forms (mapcar #'make-random-integer-form opt-sizes) + )) + (if opt-forms + `(,op ((,fname (,@(subseq arg-names 0 minargs) + &optional + ,@(mapcar #'list + (subseq arg-names minargs) + opt-forms) + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + (subseq opt-forms (- maxargs minargs))) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2) + `(,op ((,fname (,@arg-names + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + opt-forms ) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2)))))))) + +(defun make-random-tagbody (size) + (let* ((num-forms (random 6)) + (tags nil)) + (loop for i below num-forms + do (loop for tag = (rcase + #-allegro (1 (random 8)) + (1 (random-from-seq #(tag1 tag2 tag3 tag4 + tag5 tag6 tag7 tag8)))) + while (member tag tags) + finally (push tag tags))) + (assert (= (length (remove-duplicates tags)) (length tags))) + (let* ((*go-tags* (set-difference *go-tags* tags)) + (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) + (forms + (loop for tag-list on tags + for i below num-forms + for size in sizes + collect (let ((*go-tags* (append tag-list *go-tags*))) + (make-random-integer-form size))))) + `(tagbody ,@(loop for tag in tags + for form in forms + when (atom form) do (setq form `(progn ,form)) + append `(,form ,tag)))))) + +(defun make-random-tagbody-and-progn (size) + (let* ((final-size (random (max 1 (floor size 5)))) + (tagbody-size (- size final-size))) + (let ((final-form (make-random-integer-form final-size)) + (tagbody-form (make-random-tagbody tagbody-size))) + `(progn ,tagbody-form ,final-form)))) + +(defun make-random-pred-form (size) + "Make a random form whose value is to be used as a generalized boolean." + (if (<= size 1) + (rcase + (1 (if (coin) t nil)) + (2 + `(,(random-from-seq '(< <= = > >= /= eql equal)) + ,(make-random-integer-form size) + ,(make-random-integer-form size)))) + (rcase + (1 (if (coin) t nil)) + (3 `(not ,(make-random-pred-form (1- size)))) + (12 (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + `(,(random-from-seq '(and or)) + ,(make-random-pred-form leftsize) + ,(make-random-pred-form rightsize)))) + (1 (let* ((nsizes (+ 1 (random 3))) + (sizes (random-partition (1- size) nsizes))) + `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) + #(< <= > >= = /=))) + ,@(mapcar #'make-random-integer-form sizes)))) + (3 (let* ((cond-size (random (max 1 (floor size 2)))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-pred-form then-size)) + (else-part (make-random-pred-form else-size))) + `(if ,pred ,then-part ,else-part))) + #-poplog + (1 (destructuring-bind (s1 s2) + (random-partition (1- size) 2) + `(ldb-test ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2)))) + (2 (let ((form (make-random-integer-form (1- size))) + (op (random-from-seq #(evenp oddp minusp plusp zerop)))) + `(,op ,form))) + (2 (destructuring-bind (s1 s2) + (random-partition (1- size) 2) + (let ((arg1 (make-random-integer-form s1)) + (arg2-args (loop repeat s2 collect (make-random-integer)))) + (let ((op (random-from-seq #(find position))) + (test (random-from-seq #(eql = /= < > <= >=))) + (arg2 (rcase + (1 (make-array (list s2) :initial-contents arg2-args)) + (1 + (let* ((mask (1- (ash 1 (1+ (random 32)))))) + (make-array (list s2) + :initial-contents + (mapcar #'(lambda (x) (logand x mask)) arg2-args) + :element-type `(integer 0 ,mask)))) + (1 `(quote ,arg2-args))))) + `(,op ,arg1 ,arg2 ,@(rcase + (2 nil) + (1 (list :test `(quote ,test))) + (1 (list :test-not `(quote ,test))))))))) + + (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) + (form (make-random-integer-form (1- size)))) + `(logbitp ,index ,form))) + (1 ;; typep form + (let ((subform (make-random-integer-form (- size 2))) + (type + (rcase + (1 `(real ,@(make-random-integer-range))) + (1 `(rational ,@(make-random-integer-range))) + (1 `(rational ,(+ 1/2 (make-random-integer)))) + (1 `(rational * ,(+ 1/2 (make-random-integer)))) + (1 `(integer ,@(make-random-integer-range))) + (1 `(integer ,(make-random-integer))) + (1 `(integer * ,(make-random-integer))) + (1 'fixnum) + (1 'bignum) + (1 `(integer))))) + `(typep ,subform ',type))) + ))) + +(defun make-random-loop-form (size) + (if (<= size 2) + (make-random-integer-form size) + (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) + (count (random 4)) + (*vars* (cons (make-var-desc :name var :type nil) + *vars*))) + (rcase + (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) + (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) + )))) + +(defun make-random-byte-spec-form (size) + (declare (ignore size)) + (let* ((pform (random 33)) + (sform (1+ (random 33)))) + `(byte ,sform ,pform))) + +(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) + ;; 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))))) + + (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 (<= 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)) + (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)) + (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))))) + ))) +|# + +(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 + when (rcase + (3 (random-from-seq +standard-chars+)) + (3 (code-char (random (min 256 char-code-limit)))) + (1 (code-char (random (min (ash 1 16) char-code-limit)))) + (1 (code-char (random (min (ash 1 24) char-code-limit)))) + (1 (code-char (random char-code-limit)))) + return it)) + +(defun make-random-array-element-type () + ;; Create random types for array elements + (let ((bits 40)) + (rcase + (2 t) + (1 'symbol) + (1 `(unsigned-byte ,(1+ (random bits)))) + (1 `(signed-byte ,(1+ (random bits)))) + (1 'character) + (1 'base-char) + (1 'bit) + (1 (random-from-seq #(short-float single-float double-float long-float)))))) + +(defun make-random-vector (etype-spec size-spec &key simple) + (let* ((etype (if (eql etype-spec '*) + (make-random-array-element-type) + etype-spec)) + (size (if (eql size-spec '*) + (random (ash 1 (+ 2 (random 8)))) + size-spec)) + (displaced? (and (not simple) (coin 4))) + (displaced-size (+ size (random (max 6 size)))) + (displacement (random (1+ (- displaced-size size)))) + (adjustable (and (not simple) (coin 3))) + (fill-pointer (and (not simple) + (rcase (3 nil) (1 t) (1 (random (1+ size))))))) + (assert (<= size 1000000)) + (if displaced? + (let ((displaced-vector (make-array displaced-size :element-type etype + :initial-contents (loop repeat displaced-size + collect (make-random-element-of-type etype))))) + (make-array size :element-type etype :adjustable adjustable + :fill-pointer fill-pointer + :displaced-to displaced-vector + :displaced-index-offset displacement)) + (make-array size + :element-type etype + :initial-contents (loop repeat size + collect (make-random-element-of-type etype)) + :adjustable adjustable + :fill-pointer fill-pointer + )))) + +(defun make-random-array (etype-spec dim-specs &key simple) + (when (eql dim-specs '*) + (setq dim-specs (random 10))) + (when (numberp dim-specs) + (setq dim-specs (make-list dim-specs :initial-element '*))) + (let* ((etype (if (eql etype-spec '*) t etype-spec)) + (rank (length dim-specs)) + (dims (loop for dim in dim-specs + collect (if (eql dim '*) + (1+ (random (ash 1 (floor 9 rank)))) + dim)))) + (assert (<= (reduce '* dims :initial-value 1) 1000000)) + (assert (<= (reduce 'max dims :initial-value 1) 1000000)) + (make-array dims + :element-type etype + :initial-contents + (labels ((%init (dims) + (if (null dims) + (make-random-element-of-type etype) + (loop repeat (car dims) + collect (%init (cdr dims)))))) + (%init dims)) + :adjustable (and (not simple) (coin)) + ;; Do displacements later + ))) + +(defun most-negative-float (float-type-symbol) + (ecase float-type-symbol + (short-float most-negative-short-float) + (single-float most-negative-single-float) + (double-float most-negative-double-float) + (long-float most-negative-long-float) + (float (min most-negative-short-float most-negative-single-float + most-negative-double-float most-negative-long-float)))) + +(defun most-positive-float (float-type-symbol) + (ecase float-type-symbol + (short-float most-positive-short-float) + (single-float most-positive-single-float) + (double-float most-positive-double-float) + (long-float most-positive-long-float) + (float (max most-positive-short-float most-positive-single-float + most-positive-double-float most-positive-long-float)))) + +(defun make-optimized-lambda-form (form vars var-types opt-decls) + `(lambda ,vars + ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) + var-types vars) + (declare (ignorable ,@vars)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize ,@opt-decls)) + ,form)) + +(defun make-unoptimized-lambda-form (form vars var-types opt-decls) + (declare (ignore var-types)) + `(lambda ,vars + (declare (notinline ,@(fn-symbols-in-form form))) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize ,@opt-decls)) + ,form)) + +(defvar *compile-using-defun* + #-(or allegro lispworks) nil + #+(or allegro lispworks) t) + +(defvar *compile-using-defgeneric* nil + "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form + for the function and compile that.") + +(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) +(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) + +(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2) + ;; Try to compile FORM with associated VARS, and if it compiles + ;; check for equality of the two compiled forms. + ;; Return a non-nil list of details if a problem is found, + ;; NIL otherwise. + (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) + (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) + (setq *int-form-vals* nil + *optimized-fn-src* optimized-fn-src + *unoptimized-fn-src* unoptimized-fn-src) + (flet ((%compile + (lambda-form opt-defun-name) + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning) + ((or error serious-condition) + #'(lambda (c) + (format t "Compilation failure~%~A~%" + (format nil "~S" form)) + (finish-output *standard-output*) + (return-from test-int-form + (list (list :vars vars + :form form + :var-types var-types + :vals (first vals-list) + :lambda-form lambda-form + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :compiler-condition + (with-output-to-string + (s) + (prin1 c s)))))))) + (let ((start-time (get-universal-time)) + (clf (cdr lambda-form))) + (prog1 + (cond + (*compile-using-defun* + (fmakunbound opt-defun-name) + (eval `(defun ,opt-defun-name ,@clf)) + (compile opt-defun-name) + (symbol-function opt-defun-name)) + (*compile-using-defgeneric* + (fmakunbound opt-defun-name) + (eval `(defgeneric ,opt-defun-name ,(car clf))) + (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) + ,@(cdr clf))) + (compile opt-defun-name) + (symbol-function opt-defun-name)) + (t (compile nil lambda-form))) + (let* ((stop-time (get-universal-time)) + (total-time (- stop-time start-time))) + (when (> total-time *max-compile-time*) + (setf *max-compile-time* total-time) + (setf *max-compile-term* lambda-form))) + ;; #+:ecl (si:gc t) + ))))) + (let ((optimized-compiled-fn (%compile optimized-fn-src + *name-to-use-in-optimized-defun*)) + (unoptimized-compiled-fn + (if *compile-unoptimized-form* + (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) + (eval `(function ,unoptimized-fn-src))))) + (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) + (dolist (vals vals-list) + (setq *int-form-vals* vals) + (flet ((%eval-error + (kind) + (let ((*print-circle* t)) + (format t "~A~%" (format nil "~S" form))) + (finish-output *standard-output*) + (return + (list (list :vars vars + :vals vals + :form form + :var-types var-types + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :optimized-lambda-form optimized-fn-src + :unoptimized-lambda-form unoptimized-fn-src + :kind kind))))) + + (let ((unopt-result + (cl-handler-case + (cl-handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply unoptimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :unoptimized-form-error + (with-output-to-string + (s) (prin1 c s))))))) + (opt-result + (cl-handler-case + (cl-handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply optimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :optimized-form-error + (with-output-to-string + (s) (prin1 c s)))))))) + (if (equal opt-result unopt-result) + nil + (progn + (format t "Different results: ~A, ~A~%" + opt-result unopt-result) + (setq *opt-result* opt-result + *unopt-result* unopt-result) + (%eval-error (list :different-results + opt-result + unopt-result))))))))))) + +;;; Interface to the form pruner + +(declaim (special *prune-table*)) + +(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2) + "Conduct tests on selected simplified versions of INPUT-FORM. Return the + minimal form that still causes some kind of failure." + (loop do + (let ((form input-form)) + (flet ((%try-fn (new-form) + (when (test-int-form new-form vars var-types vals-list + opt-decls-1 opt-decls-2) + (setf form new-form) + (throw 'success nil)))) + (let ((*prune-table* (make-hash-table :test #'eq))) + (loop + (catch 'success + (prune form #'%try-fn) + (return form))))) + (when (equal form input-form) (return form)) + (setq input-form form)))) + +(defun prune-results (result-list) + "Given a list of test results, prune their forms down to a minimal set." + (loop for result in result-list + collect + (let* ((form (getf result :form)) + (vars (getf result :vars)) + (var-types (getf result :var-types)) + (vals-list (list (getf result :vals))) + (opt-decl-1 (getf result :decls1)) + (opt-decl-2 (getf result :decls2)) + (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) + (optimized-lambda-form (make-optimized-lambda-form + pruned-form vars var-types opt-decl-1)) + (unoptimized-lambda-form (make-unoptimized-lambda-form + pruned-form vars var-types opt-decl-2))) + `(:vars ,vars + :var-types ,var-types + :vals ,(first vals-list) + :form ,pruned-form + :decls1 ,opt-decl-1 + :decls2 ,opt-decl-2 + :optimized-lambda-form ,optimized-lambda-form + :unoptimized-lambda-form ,unoptimized-lambda-form)))) + +;;; +;;; The call (PRUNE form try-fn) attempts to simplify the lisp form +;;; so that it still satisfies TRY-FN. The function TRY-FN should +;;; return if the substitution is a failure. Otherwise, it should +;;; transfer control elsewhere via GO, THROW, etc. +;;; +;;; The return value of PRUNE should be ignored. +;;; +(defun prune (form try-fn) + (declare (type function try-fn)) + (when (gethash form *prune-table*) + (return-from prune nil)) + (flet ((try (x) (funcall try-fn x))) + (cond + ((keywordp form) nil) + ((integerp form) + (unless (zerop form) (try 0))) + ((consp form) + (let* ((op (car form)) + (args (cdr form)) + (nargs (length args))) + (case op + + ((quote) nil) + + ((go) + (try 0)) + + ((signum integer-length logcount + logandc1 logandc2 lognand lognor logorc1 logorc2 + realpart imagpart) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((make-array) + (when (and (eq (car args) nil) + (eq (cadr args) ':initial-element) + ; (null (cdddr args)) + ) + (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) + (when (cdddr args) + (try `(make-array nil :initial-element ,(caddr args)))) + )) + + ((cons) + (prune-fn form try-fn)) + + ((dotimes) + (try 0) + (let* ((binding-form (first args)) + (body (rest args)) + (var (first binding-form)) + (count-form (second binding-form)) + (result (third binding-form))) + (try result) + (unless (eql count-form 0) + (try `(dotimes (,var 0 ,result) ,@body))) + (prune result #'(lambda (form) + (try `(dotimes (,var ,count-form ,form) ,@body)))) + (when (= (length body) 1) + (prune (first body) + #'(lambda (form) + (when (consp form) + (try `(dotimes (,var ,count-form ,result) ,form)))))))) + + ((abs 1+ 1-) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((identity ignore-errors cl:handler-case restart-case locally) + (unless (and (consp args) + (consp (car args)) + (eql (caar args) 'tagbody)) + (mapc try-fn args)) + (prune-fn form try-fn)) + + ((boole) + (try (second args)) + (try (third args)) + (prune (second args) + #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) + (prune (third args) + #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) + + ((unwind-protect prog1 multiple-value-prog1) + (try (first args)) + (let ((val (first args)) + (rest (rest args))) + (when rest + (try `(unwind-protect ,val)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(unwind-protect ,val + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i)))))))) + (prune-fn form try-fn)) + + ((prog2) + (assert (>= (length args) 2)) + (let ((val1 (first args)) + (arg2 (second args)) + (rest (cddr args))) + (try arg2) + (prune-fn form try-fn) + (when rest + (try `(prog2 ,val1 ,arg2)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(prog2 ,val1 ,arg2 + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i))))))))) + + ((typep) + (try (car args)) + (prune (car args) + #'(lambda (form) `(,op ,form ,@(cdr args))))) + + ((load-time-value) + (let ((arg (first args))) + (try arg) + (cond + ((cdr args) + (try `(load-time-value ,arg)) + (prune arg + #'(lambda (form) + (try `(load-time-value ,form ,(second args)))))) + (t + (prune arg + #'(lambda (form) + (try `(load-time-value ,form)))))))) + + ((eval) + (try 0) + (let ((arg (first args))) + (cond + ((consp arg) + (cond + ((eql (car arg) 'quote) + (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) + (t + (try arg) + (prune arg #'(lambda (form) `(eval ,form)))))) + (t (try arg))))) + + ((the macrolet cl:handler-bind restart-bind) + (assert (= (length args) 2)) + (try (second args)) + (prune (second args) try-fn)) + + ((not eq eql equal) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-fn form try-fn) + ) + + ((and or = < > <= >= /=) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((- + * min max logand logior logxor logeqv gcd lcm values) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((/) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (try (car args)) + (when (cddr args) + (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) + + ((expt rationalize rational numberator denominator) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((coerce) + (try 0) + (try (car args)) + (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args)))))) + + + ((multiple-value-call) + ;; Simplify usual case + (when (= nargs 2) + (destructuring-bind (arg1 arg2) args + (when (and (consp arg1) (consp arg2) + (eql (first arg1) 'function) + (eql (first arg2) 'values)) + (mapc try-fn (rest arg2)) + (let ((fn (second arg1))) + (when (symbolp fn) + (try `(,fn ,@(rest arg2))))) + ;; Prune the VALUES form + (prune-list (rest arg2) + #'prune + #'(lambda (args) + (try `(multiple-value-call ,arg1 (values ,@args))))) + ))) + (mapc try-fn (rest args))) + + ((bit sbit elt aref svref) + (try 0) + (when (= (length args) 2) + (let ((arg1 (car args)) + (arg2 (cadr args))) + (when (and (consp arg2) + (eql (car arg2) 'min) + (integerp (cadr arg2))) + (let ((arg2.2 (caddr arg2))) + (try arg2.2) + (when (and (consp arg2.2) + (eql (car arg2.2) 'max) + (integerp (cadr arg2.2))) + (prune (caddr arg2.2) + #'(lambda (form) + (try `(,op ,arg1 (min ,(cadr arg2) + (max ,(cadr arg2.2) ,form)))))))))))) + + ((car cdr) + (try 0) + (try 1)) + + ((if) + (let (;; (pred (first args)) + (then (second args)) + (else (third args))) + (try then) + (try else) + (when (every #'constantp args) + (try (eval form))) + (prune-fn form try-fn))) + + ((incf decf) + (try 0) + (assert (member (length form) '(2 3))) + (try (first args)) + (when (> (length args) 1) + (try (second args)) + (try `(,op ,(first args))) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form))))))) + + ((setq setf shiftf) + (try 0) + ;; Assumes only one assignment + (assert (= (length form) 3)) + (try (first args)) + (try (second args)) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((rotatef) + (try 0) + (mapc try-fn (cdr form))) + + ((multiple-value-setq) + (try 0) + ;; Assumes only one assignment, and one variable + (assert (= (length form) 3)) + (assert (= (length (first args)) 1)) + (try `(setq ,(caar args) ,(cadr args))) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((byte) + (prune-fn form try-fn)) + + ((deposit-field dpb) + (try 0) + (destructuring-bind (a1 a2 a3) + args + (try a1) + (try a3) + (when (and (integerp a1) + (integerp a3) + (and (consp a2) + (eq (first a2) 'byte) + (integerp (second a2)) + (integerp (third a2)))) + (try (eval form)))) + (prune-fn form try-fn)) + + ((ldb mask-field) + (try 0) + (try (second args)) + (when (and (consp (first args)) + (eq 'byte (first (first args))) + (every #'numberp (cdr (first args))) + (numberp (second args))) + (try (eval form))) + (prune-fn form try-fn)) + + ((ldb-test) + (try t) + (try nil) + (prune-fn form try-fn)) + + ((let let*) + (prune-let form try-fn)) + + ((multiple-value-bind) + (assert (= (length args) 3)) + (let ((arg1 (first args)) + (arg2 (second args)) + (body (caddr args))) + (when (= (length arg1) 1) + (try `(let ((,(first arg1) ,arg2)) ,body))) + (prune arg2 #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,form ,body)))) + (prune body #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) + + ((block) + (let ((name (second form)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the block entirely if it is not in use + (when (not (find-in-tree name body)) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block <n> (return-from <n> <e>)) + (when (and (consp form1) + (eq (first form1) 'return-from) + (eq (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(block ,name ,x)))))))) + + ((catch) + (let* ((tag (second form)) + (name (if (consp tag) (cadr tag) tag)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the catch entirely if it is not in use + ;; We make assumptions here about what throws can + ;; be present. + (when (or (not (find-in-tree 'throw body)) + (not (find-in-tree name body))) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block <n> (return-from <n> <e>)) + (when (and (consp form1) + (eq (first form1) 'throw) + (equal (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(catch ,tag ,x)))))))) + + ((throw) + (try (second args)) + (prune (second args) + #'(lambda (x) (try `(throw ,(first args) ,x))))) + + ((flet labels) + (try 0) + (prune-flet form try-fn)) + + ((case) + (prune-case form try-fn)) + + ((isqrt) + (let ((arg (second form))) + (assert (null (cddr form))) + (assert (consp arg)) + (assert (eq (first arg) 'abs)) + (let ((arg2 (second arg))) + (try arg2) + ;; Try to fold + (when (integerp arg2) + (try (isqrt (abs arg2)))) + ;; Otherwise, simplify arg2 + (prune arg2 #'(lambda (form) + (try `(isqrt (abs ,form)))))))) + + ((ash) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (try form2) + (prune form1 + #'(lambda (form) + (try `(ash ,form ,form2)))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (eq (first form2) 'min) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(ash ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((floor ceiling truncate round mod rem) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (when (cddr form) (try form2)) + (prune form1 + (if (cddr form) + #'(lambda (form) + (try `(,op ,form ,form2))) + #'(lambda (form) (try `(,op ,form))))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (member (first form2) '(max min)) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(,op ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((constantly) + (unless (eql (car args) 0) + (prune (car args) + #'(lambda (arg) (try `(constantly ,arg)))))) + + ((funcall) + (try 0) + (let ((fn (second form)) + (fn-args (cddr form))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(funcall (constantly 0) ,@fn-args))) + (when (and (consp fn) + (eql (car fn) 'function) + (symbolp (cadr fn))) + (try `(,(cadr fn) ,@fn-args))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(funcall ,fn ,@args)))))) + + ((reduce) + (try 0) + (let ((arg1 (car args)) + (arg2 (cadr args)) + (rest (cddr args))) + (when (and ;; (null (cddr args)) + (consp arg1) + (eql (car arg1) 'function)) + (let ((arg1.2 (cadr arg1))) + (when (and (consp arg1.2) + (eql (car arg1.2) 'lambda)) + (let ((largs (cadr arg1.2)) + (body (cddr arg1.2))) + (when (null (cdr body)) + (prune (car body) + #'(lambda (bform) + (try `(reduce (function (lambda ,largs ,bform)) + ,arg2 ,@rest))))))))) + (when (consp arg2) + (case (car arg2) + ((list vector) + (let ((arg2.rest (cdr arg2))) + (mapc try-fn arg2.rest) + (prune-list arg2.rest + #'prune + #'(lambda (args) + (try `(reduce ,arg1 + (,(car arg2) ,@args) + ,@rest)))))))))) + + ((apply) + (try 0) + (let ((fn (second form)) + (fn-args (butlast (cddr form))) + (list-arg (car (last form)))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(apply (constantly 0) ,@(cddr form)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (mapc try-fn (cdr list-arg))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(apply ,fn ,@args ,list-arg)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) + (prune-list (cdr list-arg) + #'prune + #'(lambda (args) + (try `(apply ,fn ,@fn-args + (list ,@args)))))))) + + ((progv) + (try 0) + (prune-progv form try-fn)) + + ((tagbody) + (try 0) + (prune-tagbody form try-fn)) + + ((progn) + (when (null args) (try nil)) + (try (car (last args))) + (loop for i from 0 below (1- (length args)) + for a in args + do (try `(progn ,@(subseq args 0 i) + ,@(subseq args (1+ i)))) + do (when (and (consp a) + (or + (eq (car a) 'progn) + (and (eq (car a) 'tagbody) + (every #'consp (cdr a))))) + (try `(progn ,@(subseq args 0 i) + ,@(copy-list (cdr a)) + ,@(subseq args (1+ i)))))) + (prune-fn form try-fn)) + + ((loop) + (try 0) + (when (and (eql (length args) 6) + (eql (elt args 0) 'for) + (eql (elt args 2) 'below)) + (let ((var (elt args 1)) + (count (elt args 3)) + (form (elt args 5))) + (unless (eql count 0) (try count)) + (case (elt args 4) + (sum + (try `(let ((,(elt args 1) 0)) ,(elt args 5))) + (prune form #'(lambda (form) + (try `(loop for ,var below ,count sum ,form))))) + (count + (unless (or (eql form t) (eql form nil)) + (try `(loop for ,var below ,count count t)) + (try `(loop for ,var below ,count count nil)) + (prune form + #'(lambda (form) + (try `(loop for ,var below ,count count ,form)))))) + )))) + + (otherwise + (try 0) + (prune-fn form try-fn)) + + ))))) + (setf (gethash form *prune-table*) t) + nil) + +(defun find-in-tree (value tree) + "Return true if VALUE is eql to a node in TREE." + (or (eql value tree) + (and (consp tree) + (or (find-in-tree value (car tree)) + (find-in-tree value (cdr tree)))))) + +(defun prune-list (list element-prune-fn list-try-fn) + (declare (type function element-prune-fn list-try-fn)) + "Utility function for pruning in a list." + (loop for i from 0 + for e in list + do (funcall element-prune-fn + e + #'(lambda (form) + (funcall list-try-fn + (append (subseq list 0 i) + (list form) + (subseq list (1+ i)))))))) + +(defun prune-case (form try-fn) + (declare (type function try-fn)) + (flet ((try (e) (funcall try-fn e))) + (let* ((op (first form)) + (expr (second form)) + (cases (cddr form))) + + ;; Try just the top expression + (try expr) + + ;; Try simplifying the expr + (prune expr + #'(lambda (form) + (try `(,op ,form ,@cases)))) + + ;; Try individual cases + (loop for case in cases + do (try (first (last (rest case))))) + + ;; Try deleting individual cases + (loop for i from 0 below (1- (length cases)) + do (try `(,op ,expr + ,@(subseq cases 0 i) + ,@(subseq cases (1+ i))))) + + ;; Try simplifying the cases + ;; Assume each case has a single form + (prune-list cases + #'(lambda (case try-fn) + (declare (type function try-fn)) + (when (and (listp (car case)) + (> (length (car case)) 1)) + ;; try removing constants + (loop for i below (length (car case)) + do (funcall try-fn + `((,@(subseq (car case) 0 i) + ,@(subseq (car case) (1+ i))) + ,@(cdr case))))) + (when (eql (length case) 2) + (prune (cadr case) + #'(lambda (form) + (funcall try-fn + (list (car case) form)))))) + #'(lambda (cases) + (try `(,op ,expr ,@cases))))))) + +(defun prune-tagbody (form try-fn) + (declare (type function try-fn)) + (let (;; (op (car form)) + (body (cdr form))) + (loop for i from 0 + for e in body + do + (cond + ((atom e) + ;; A tag + (unless (find-in-tree e (subseq body 0 i)) + (funcall try-fn `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))))) + (t + (funcall try-fn + `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))) + (prune e + #'(lambda (form) + ;; Don't put an atom here. + (when (consp form) + (funcall + try-fn + `(tagbody ,@(subseq body 0 i) + ,form + ,@(subseq body (1+ i)))))))))))) + +(defun prune-progv (form try-fn) + (declare (type function try-fn)) + (let (;; (op (car form)) + (vars-form (cadr form)) + (vals-form (caddr form)) + (body-list (cdddr form))) + (when (and (null vars-form) (null vals-form)) + (funcall try-fn `(let () ,@body-list))) + (when (and (consp vals-form) (eql (car vals-form) 'list)) + (when (and (consp vars-form) (eql (car vars-form) 'quote)) + (let ((vars (cadr vars-form)) + (vals (cdr vals-form))) + (when (eql (length vars) (length vals)) + (let ((let-form `(let () ,@body-list))) + (mapc #'(lambda (var val) + (setq let-form `(let ((,var ,val)) ,let-form))) + vars vals) + (funcall try-fn let-form))) + ;; Try simplifying the vals forms + (prune-list vals + #'prune + #'(lambda (vals) + (funcall try-fn + `(progv ,vars-form (list ,@vals) ,@body-list))))))) + ;; Try simplifying the body + (when (eql (length body-list) 1) + (prune (car body-list) + #'(lambda (form) + (funcall try-fn + `(progv ,vars-form ,vals-form ,form))))))) + +(defun prune-nary-fn (form try-fn) + ;; Attempt to reduce the number of arguments to the fn + ;; Do not reduce below 1 + (declare (type function try-fn)) + (let* ((op (car form)) + (args (cdr form)) + (nargs (length args))) + (when (> nargs 1) + (loop for i from 1 to nargs + do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) + ,@(subseq args i))))))) + +(defun prune-fn (form try-fn) + "Attempt to simplify a function call form. It is considered + acceptable to replace the call by one of its argument forms." + (declare (type function try-fn)) + (prune-list (cdr form) + #'prune + #'(lambda (args) + (funcall try-fn (cons (car form) args))))) + +(defun prune-let (form try-fn) + "Attempt to simplify a LET form." + (declare (type function try-fn)) + (let* ((op (car form)) + (binding-list (cadr form)) + (body (cddr form)) + (body-len (length body)) + (len (length binding-list)) + ) + + (when (> body-len 1) + (funcall try-fn `(,op ,binding-list ,@(cdr body)))) + + ;; Try to simplify (let ((<name> <form>)) ...) to <form> + #| + (when (and (>= len 1) + ;; (eql body-len 1) + ;; (eql (caar binding-list) (car body)) + ) + (let ((val-form (cadar binding-list))) + (unless (and (consp val-form) + (eql (car val-form) 'make-array)) + (funcall try-fn val-form)))) + |# + + (when (>= len 1) + (let ((val-form (cadar binding-list))) + (when (consp val-form) + (case (car val-form) + ((make-array) + (let ((init (getf (cddr val-form) :initial-element))) + (when init + (funcall try-fn init)))) + ((cons) + (funcall try-fn (cadr val-form)) + (funcall try-fn (caddr val-form))))))) + + ;; Try to simplify the forms in the RHS of the bindings + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (prune (cadr binding) + #'(lambda (form) + (funcall try-fn + (list (car binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + ;; Prune off unused variable + (when (and binding-list + (not (rest binding-list)) + (let ((name (caar binding-list))) + (and (symbolp name) + (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) + (funcall try-fn `(progn ,@body))) + + ;; Try to simplify the body of the LET form + (when body + (unless binding-list + (funcall try-fn (car (last body)))) + (when (and (first binding-list) + (not (rest binding-list)) + (not (rest body))) + (let ((binding (first binding-list))) + (unless (or (consp (second binding)) + (has-binding-to-var (first binding) body) + (has-assignment-to-var (first binding) body) + ) + (funcall try-fn `(let () + ,@(subst (second binding) + (first binding) + (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) + body) + )))))) + (prune (car (last body)) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) + +(defun has-assignment-to-var (var form) + (find-if-subtree + #'(lambda (form) + (and (consp form) + (or + (and (member (car form) '(setq setf shiftf incf decf) :test #'eq) + (eq (cadr form) var)) + (and (eql (car form) 'multiple-value-setq) + (member var (cadr form)))))) + form)) + +(defun has-binding-to-var (var form) + (find-if-subtree + #'(lambda (form) + (and (consp form) + (case (car form) + ((let let*) + (loop for binding in (cadr form) + thereis (eq (car binding) var))) + ((progv) + (and (consp (cadr form)) + (eq (caadr form) 'quote) + (consp (second (cadr form))) + (member var (second (cadr form))))) + (t nil)))) + form)) + +(defun find-if-subtree (pred tree) + (declare (type function pred)) + (cond + ((funcall pred tree) tree) + ((consp tree) + (or (find-if-subtree pred (car tree)) + (find-if-subtree pred (cdr tree)))) + (t nil))) + +(defun prune-flet (form try-fn) + "Attempt to simplify a FLET form." + (declare (type function try-fn)) + + (let* ((op (car form)) + (binding-list (cadr form)) + (body (cddr form))) + + ;; Remove a declaration, if any + (when (and (consp body) + (consp (car body)) + (eq (caar body) 'declare)) + (funcall try-fn `(,op ,binding-list ,@(cdr body)))) + + ;; Try to prune optional arguments + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (let* ((name (car binding)) + (args (cadr binding)) + (body (cddr binding)) + (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) + (the list args)))) + (when opt-pos + (incf opt-pos) + (let ((normal-args (subseq args 0 (1- opt-pos))) + (optionals (subseq args opt-pos))) + (prune-list optionals + #'(lambda (opt-lambda-arg try-fn) + (declare (type function try-fn)) + (when (consp opt-lambda-arg) + (let ((name (first opt-lambda-arg)) + (form (second opt-lambda-arg))) + (prune form + #'(lambda (form) + (funcall try-fn (list name form))))))) + #'(lambda (opt-args) + (funcall try-fn + `(,name (,@normal-args + &optional + ,@opt-args) + ,@body)))))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + + ;; Try to simplify the forms in the RHS of the bindings + (prune-list binding-list + #'(lambda (binding try-fn) + (declare (type function try-fn)) + + ;; Prune body of a binding + (prune (third binding) + #'(lambda (form) + (funcall try-fn + (list (first binding) + (second binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + + ;; ;; Try to simplify the body of the FLET form + (when body + + ;; No bindings -- try to simplify to the last form in the body + (unless binding-list + (funcall try-fn (first (last body)))) + + (when (and (consp binding-list) + (null (rest binding-list))) + (let ((binding (first binding-list))) + ;; One binding -- match on (flet ((<name> () <body>)) (<name>)) + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) (rest binding))) + (null (second binding)) + (equal body (list (list (first binding))))) + (funcall try-fn `(,op () ,@(cddr binding)))) + ;; One binding -- try to remove it if not used + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) body))) + (funcall try-fn (first (last body)))) + )) + + + ;; Try to simplify (the last form in) the body. + (prune (first (last body)) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) + +;;; Routine to walk form, applying a function at each form +;;; The fn is applied in preorder. When it returns :stop, do +;;; not descend into subforms + +#| +(defun walk (form fn) + (declare (type function fn)) + (unless (eq (funcall fn form) :stop) + (when (consp form) + (let ((op (car form))) + (case op + ((let let*) + (walk-let form fn)) + ((cond) + (dolist (clause (cdr form)) + (walk-implicit-progn clause fn))) + ((multiple-value-bind) + (walk (third form) fn) + (walk-body (cdddr form) fn)) + ((function quote declare) nil) + ((block the return-from) + (walk-implicit-progn (cddr form) fn)) + ((case typecase) + (walk (cadr form) fn) + (dolist (clause (cddr form)) + (walk-implicit-progn (cdr clause) fn))) + ((flet labels) + + + + +|# + +;;;;;;;;;;;;;;;;;;;;;; +;;; Convert pruned results to test cases + +(defun produce-test-cases (instances &key + (stream *standard-output*) + (prefix "MISC.") + (index 1)) + (dolist (inst instances) + (let* (;; (vars (getf inst :vars)) + (vals (getf inst :vals)) + (optimized-lambda-form (getf inst :optimized-lambda-form)) + (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) + (name (intern + (concatenate 'string prefix (format nil "~D" index)) + "CL-TEST")) + (test-form + `(deftest ,name + (let* ((fn1 ',optimized-lambda-form) + (fn2 ',unoptimized-lambda-form) + (vals ',vals) + (v1 (apply (compile nil fn1) vals)) + (v2 (apply (compile nil fn2) vals))) + (if (eql v1 v2) + :good + (list v1 v2))) + :good))) + (print test-form stream) + (terpri stream) + (incf index))) + (values)) diff --git a/random/random-intern.lsp b/random/random-intern.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5041b984197cb1b1b35bf8156def59a176fcce88 --- /dev/null +++ b/random/random-intern.lsp @@ -0,0 +1,72 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Code to randomly intern and unintern random strings +;;;; in a package. Exercises package and hash table routines + +(in-package :cl-test) + +(defconstant +max-len-random-symbol+ 63) + +(defun make-random-symbol (package) + (declare (optimize (speed 3) (safety 3))) + (loop + (let* ((len (random (1+ +max-len-random-symbol+))) + (str (make-string len))) + (declare (type (integer 0 #.+max-len-random-symbol+) len)) + (loop + for i from 0 to (1- len) do + (setf (schar str i) + (schar +base-chars+ + (random +num-base-chars+)))) + (multiple-value-bind + (symbol status) + (intern (copy-seq str) package) + (unless (equal str (symbol-name symbol)) + (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) + (unless status (return symbol)))))) + +(defun queue-insert (q x) + (declare (type cons q)) + (push x (cdr q))) + +(defun queue-remove (q) + (declare (type cons q)) + (when (null (car q)) + (when (null (cdr q)) + (error "Attempty to remove from empty queue.~%")) + (setf (car q) (nreverse (cdr q))) + (setf (cdr q) nil)) + (pop (car q))) + +(defun queue-empty (q) + (and (null (car q)) + (null (cdr q)))) + +(defun random-intern (n) + (declare (fixnum n)) + (let ((q (list nil)) + (xp (defpackage "X" (:use)))) + (declare (type cons q)) + (loop + for i from 1 to n do + (if (and + (= (random 2) 0) + (not (queue-empty q))) + (unintern (queue-remove q) xp) + (queue-insert q (make-random-symbol xp)))))) + +(defun fill-intern (n) + (declare (fixnum n)) + (let ((xp (defpackage "X" (:use)))) + (loop + for i from 1 to n do + (make-random-symbol xp)))) + + + + + + + + + diff --git a/random/random-type-prop-tests-01.lsp b/random/random-type-prop-tests-01.lsp new file mode 100644 index 0000000000000000000000000000000000000000..da3a53e44b7e80b2957c6e032fa9886dd224b29a --- /dev/null +++ b/random/random-type-prop-tests-01.lsp @@ -0,0 +1,73 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 6 20:36:56 2005 +;;;; Contains: Test that invoke the random type prop infrastructure, part 1 + +(in-package :cl-test) + +(def-type-prop-test special-operator-p 'special-operator-p '(symbol) 1) +(def-type-prop-test type-of 'type-of '(t) 1) +(def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2) +(def-type-prop-test typep.2 'typep + (list t #'(lambda (x) + (let ((type (make-random-type-containing x))) + `(eql ,type)))) + 2) +(def-type-prop-test subtypep + '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2) +(def-type-prop-test fboundp.1 'fboundp '(symbol) 1) +(def-type-prop-test fboundp.2 'fboundp '((cons (eql setf) (cons symbol null))) 1) +(def-type-prop-test functionp 'functionp '(t) 1) +(def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1) +(def-type-prop-test not 'not '(t) 1) +(def-type-prop-test eq 'eq (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 '(and t (not number) (not character)))))) + 2) +(def-type-prop-test eql.1 'eql '(t t) 2) +(def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2) +(def-type-prop-test equal.1 'equal '(t t) 2) +(def-type-prop-test equal.2 'equal (list t #'(lambda (x) `(eql ,x))) 2) +(def-type-prop-test equalp.1 'equalp '(t t) 2) +(def-type-prop-test equalp.2 'equalp (list t #'(lambda (x) `(eql ,x))) 2) +(def-type-prop-test identity 'identity '(t) 1) +(def-type-prop-test complement + '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2) +(def-type-prop-test constantly + '(lambda (x) (funcall (constantly x))) '(t) 1) +(def-type-prop-test and.1 'and '(t) 1) +(def-type-prop-test and.2 'and '((or null t) t) 2) +(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) +(def-type-prop-test when 'when '((or null t) t) 2) +(def-type-prop-test unless 'unless '((or null t) t) 2) +(def-type-prop-test slot-exists-p 'slot-exists-p '(t symbol) 2) +(def-type-prop-test find-class 'find-class '(symbol null) 2) +(def-type-prop-test class-of 'class-of '(t) 1) +(def-type-prop-test find-restart 'find-restart '((and symbol (not null))) 1) +(def-type-prop-test symbolp 'symbolp '(t) 1) +(def-type-prop-test keywordp 'keywordp '(t) 1) +(def-type-prop-test make-symbol 'make-symbol '(string) 1 + :test #'(lambda (x y) (string= (symbol-name x) (symbol-name y)))) +(def-type-prop-test symbol-name 'symbol-name '(symbol) 1) +(def-type-prop-test symbol-package 'symbol-package '(symbol) 1) +(def-type-prop-test boundp 'boundp '(symbol) 1) +(def-type-prop-test find-symbol 'find-symbol '(string) 1) +(def-type-prop-test find-package 'find-package '((or string symbol character)) 1) + diff --git a/random/random-type-prop-tests-02.lsp b/random/random-type-prop-tests-02.lsp new file mode 100644 index 0000000000000000000000000000000000000000..458aa8fcd5acbc35556386a6f4d07a6c9c42f8d5 --- /dev/null +++ b/random/random-type-prop-tests-02.lsp @@ -0,0 +1,115 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 6 20:37:57 2005 +;;;; Contains: Tests that invoke the random type prop infrastructure, part 2 + +(in-package :cl-test) + +(def-type-prop-test =.1 '= '(number number) 2) +(def-type-prop-test =.2 '= '(number number number) 3) +(def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number) +(def-type-prop-test =.4 '= '(integer integer) 2) +(def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number + `(eql ,x)))) 2) +(def-type-prop-test =.6 '= (list 'number 'number + #'(lambda (x y) (rcase + (2 'number) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) +(def-type-prop-test /=.1 '/= '(number number) 2) +(def-type-prop-test /=.2 '/= '(number number number) 3) +(def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number) +(def-type-prop-test /=.4 '/= '(integer integer) 2) +(def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number + `(eql ,x)))) 2) +(def-type-prop-test /=.6 '/= (list 'number 'number + #'(lambda (x y) (rcase + (2 'number) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) +(def-type-prop-test <.1 '< '(real real) 2) +(def-type-prop-test <.2 '< '(real real real) 3) +(def-type-prop-test <.3 '< nil 4 :maxargs 10 :rest-type 'real) +(def-type-prop-test <.4 '< '(integer integer) 2) +(def-type-prop-test <.5 '< (list 'real #'(lambda (x) (if (coin) 'real + `(eql ,x)))) 2) +(def-type-prop-test <.6 '< (list 'real 'real + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) +(def-type-prop-test >.1 '> '(real real) 2) +(def-type-prop-test >.2 '> '(real real real) 3) +(def-type-prop-test >.3 '> nil 4 :maxargs 10 :rest-type 'real) +(def-type-prop-test >.4 '> '(integer integer) 2) +(def-type-prop-test >.5 '> (list 'real #'(lambda (x) (if (coin) 'real + `(eql ,x)))) 2) +(def-type-prop-test >.6 '> (list 'real 'real + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) +(def-type-prop-test <=.1 '<= '(real real) 2) +(def-type-prop-test <=.2 '<= '(real real real) 3) +(def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real) +(def-type-prop-test <=.4 '<= '(integer integer) 2) +(def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real + `(eql ,x)))) 2) +(def-type-prop-test <=.6 '<= (list 'real 'real + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) +(def-type-prop-test >=.1 '>= '(real real) 2) +(def-type-prop-test >=.2 '>= '(real real real) 3) +(def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real) +(def-type-prop-test >=.4 '>= '(integer integer) 2) +(def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real + `(eql ,x)))) 2) +(def-type-prop-test >=.6 '>= (list 'real 'real + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) + 3) + +(def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer) +(def-type-prop-test min.2 'min nil 2 :maxargs 6 :rest-type 'rational) +(def-type-prop-test min.3 'min nil 2 :maxargs 6 :rest-type 'real) +(def-type-prop-test max.1 'max nil 2 :maxargs 6 :rest-type 'integer) +(def-type-prop-test max.2 'max nil 2 :maxargs 6 :rest-type 'rational) +(def-type-prop-test max.3 'max nil 2 :maxargs 6 :rest-type 'real) + +(def-type-prop-test minusp 'minusp '(real) 1) +(def-type-prop-test plusp 'plusp '(real) 1) +(def-type-prop-test zerop 'zerop '(number) 1) + +(def-type-prop-test floor.1 'floor '(real) 1) +(def-type-prop-test floor.2 'floor '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test floor.3 'floor '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test ffloor.1 'ffloor '(real) 1) +(def-type-prop-test ffloor.2 'ffloor '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test ffloor.3 'ffloor '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test ceiling.1 'ceiling '(real) 1) +(def-type-prop-test ceiling.2 'ceiling '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test ceiling.3 'ceiling '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test fceiling.1 'fceiling '(real) 1) +(def-type-prop-test fceiling.2 'fceiling '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test fceiling.3 'fceiling '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test truncate.1 'truncate '(real) 1) +(def-type-prop-test truncate.2 'truncate '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test truncate.3 'truncate '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test ftruncate.1 'ftruncate '(real) 1) +(def-type-prop-test ftruncate.2 'ftruncate '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test ftruncate.3 'ftruncate '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test round.1 'round '(real) 1) +(def-type-prop-test round.2 'round '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test round.3 'round '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test fround.1 'fround '(real) 1) +(def-type-prop-test fround.2 'fround '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test fround.3 'fround '(real (and real (not (satisfies zerop)))) 2) diff --git a/random/random-type-prop-tests-03.lsp b/random/random-type-prop-tests-03.lsp new file mode 100644 index 0000000000000000000000000000000000000000..a564c2149995b22582a99d8466e46819fe08ad2a --- /dev/null +++ b/random/random-type-prop-tests-03.lsp @@ -0,0 +1,186 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 6 20:39:10 2005 +;;;; Contains: Tests that invoke the random type prop infrastructure, part 3 + +(in-package :cl-test) + +;;; trig, hyperbolic functions here + +;;; WARNING -- these tests may cause floating point overflow/underflow +;;; Ignore those failures +(def-type-prop-test *.1 '* '(integer integer) 2) +(def-type-prop-test *.2 '* nil 1 :rest-type 'integer :maxargs 4) +(def-type-prop-test *.3 '* nil 2 :rest-type 'integer :maxargs 10) +(def-type-prop-test *.4 '* '(real real) 2 :test #'approx=) +(def-type-prop-test *.5 '* '(number number) 2 :test #'approx=) + +(def-type-prop-test \+.1 '+ '(integer integer) 2) +(def-type-prop-test \+.2 '+ nil 1 :rest-type 'integer :maxargs 4) +(def-type-prop-test \+.3 '+ nil 2 :rest-type 'integer :maxargs 10) +(def-type-prop-test \+.4 '+ '(real real) 2 :test #'approx=) +(def-type-prop-test \+.5 '+ '(number number) 2 :test #'approx=) + +(def-type-prop-test \-.1 '- '(integer integer) 2) +(def-type-prop-test \-.2 '- nil 1 :rest-type 'integer :maxargs 4) +(def-type-prop-test \-.3 '- nil 2 :rest-type 'integer :maxargs 10) +(def-type-prop-test \-.4 '- '(real real) 2 :test #'approx=) +(def-type-prop-test \-.5 '- '(number number) 2 :test #'approx=) +(def-type-prop-test \-.6 '- '(number) 1) + +;;; WARNING -- these tests may cause floating point overflow/underflow +;;; Ignore those failures +(def-type-prop-test /.1 '/ '((and integer (not (satisfies zerop)))) 1) +(def-type-prop-test /.2 '/ '((and rational (not (satisfies zerop)))) 1) +(def-type-prop-test /.3 '/ '((and real (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) +(def-type-prop-test /.4 '/ '((and complex (not (satisfies zerop)))) 1 :ignore 'arithmetic-error) +(def-type-prop-test /.5 '/ '(integer) 2 :maxargs 6 :rest-type '(and integer (not (satisfies zerop)))) +(def-type-prop-test /.6 '/ '(rational) 2 :maxargs 6 :rest-type '(and rational (not (satisfies zerop)))) +(def-type-prop-test /.7 '/ '(real) 2 :maxargs 6 :rest-type '(and real (not (satisfies zerop))) + :test #'approx= :ignore 'arithmetic-error) +(def-type-prop-test /.8 '/ '(number) 2 :maxargs 6 :rest-type '(and number (not (satisfies zerop))) + :test #'approx= :ignore 'arithmetic-error) + +(def-type-prop-test 1+.1 '1+ '(integer) 1) +(def-type-prop-test 1+.2 '1+ '(rational) 1) +(def-type-prop-test 1+.3 '1+ '(real) 1) +(def-type-prop-test 1+.4 '1+ '(number) 1) + +(def-type-prop-test 1-.1 '1- '(integer) 1) +(def-type-prop-test 1-.2 '1- '(rational) 1) +(def-type-prop-test 1-.3 '1- '(real) 1) +(def-type-prop-test 1-.4 '1- '(number) 1) + +(def-type-prop-test abs.1 'abs '(integer) 1) +(def-type-prop-test abs.2 'abs '(rational) 1) +(def-type-prop-test abs.3 'abs '(real) 1) +(def-type-prop-test abs.4 'abs '(number) 1) + +(def-type-prop-test evenp 'evenp '(integer) 1) +(def-type-prop-test oddp 'oddp '(integer) 1) + +;;; exp, expt here + +(def-type-prop-test gcd 'gcd nil 1 :maxargs 6 :rest-type 'integer) +(def-type-prop-test lcm 'lcm nil 1 :maxargs 6 :rest-type 'integer) + +(def-type-prop-test log.1 'log '((and real (not (satisfies zerop)))) 1 :test #'approx=) +(def-type-prop-test log.2 'log '((and number (not (satisfies zerop)))) 1 :test #'approx=) + +(def-type-prop-test mod.1 'mod '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test mod.2 'mod '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) +(def-type-prop-test rem.1 'rem '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test rem.2 'rem '(real (and real (not (satisfies zerop)))) 2 :test #'approx=) + +(def-type-prop-test signum.1 'signum '(integer) 1) +(def-type-prop-test signum.2 'signum '(rational) 1) +(def-type-prop-test signum.3 'signum '(real) 1) +(def-type-prop-test signum.4 'signum '(number) 1) + +(def-type-prop-test sqrt.1 'sqrt '(integer) 1 :test #'approx=) +(def-type-prop-test sqrt.2 'sqrt '(rational) 1 :test #'approx=) +(def-type-prop-test sqrt.3 'sqrt '(real) 1 :test #'approx=) +(def-type-prop-test sqrt.4 'sqrt '(number) 1 :test #'approx=) + +(def-type-prop-test isqrt 'isqrt '((integer 0)) 1) + +(def-type-prop-test numberp 'numberp '(t) 1) + +(def-type-prop-test complex.1 'complex '(integer) 1) +(def-type-prop-test complex.2 'complex '(rational) 1) +(def-type-prop-test complex.3 'complex '(real) 1) +(def-type-prop-test complex.4 'complex '(rational rational) 2) +(def-type-prop-test complex.5 'complex '(real real) 2) + +(def-type-prop-test complexp 'complexp '(t) 1) + +(def-type-prop-test conjugate 'conjugate '(number) 1) + +(def-type-prop-test phase.1 'phase '(real) 1) +(def-type-prop-test phase.2 'phase '(number) 1 :test #'approx=) + +(def-type-prop-test realpart.1 'realpart '(real) 1) +(def-type-prop-test realpart.2 'realpart '(number) 1) +(def-type-prop-test imagpart.1 'imagpart '(real) 1) +(def-type-prop-test imagpart.2 'imagpart '(number) 1) + +(def-type-prop-test realp 'realp '(t) 1) + +(def-type-prop-test numerator 'numerator '(rational) 1) +(def-type-prop-test denominator 'denominator '(rational) 1) + +(def-type-prop-test rational 'rational '(real) 1) +(def-type-prop-test rationalize 'rationalize '(real) 1) + +(def-type-prop-test rationalp 'rationalp '(t) 1) + +(def-type-prop-test ash.1 'ash '(integer (integer -32 32)) 2) +(def-type-prop-test ash.2 'ash '(integer (integer -100 100)) 2) + +(def-type-prop-test integer-length 'integer-length '(integer) 1) +(def-type-prop-test integerp 'integerp '(t) 1) + +(def-type-prop-test logand.1 'logand '(integer integer) 2) +(def-type-prop-test logand.2 'logand nil 2 :rest-type 'integer :maxargs 6) + +(def-type-prop-test logandc1 'logandc1 '(integer integer) 2) +(def-type-prop-test logandc2 'logandc2 '(integer integer) 2) + +(def-type-prop-test lognand 'lognand '(integer integer) 2) +(def-type-prop-test lognor 'lognor '(integer integer) 2) + +(def-type-prop-test logeqv.1 'logeqv '(integer integer) 2) +(def-type-prop-test logeqv.2 'logeqv nil 2 :rest-type 'integer :maxargs 6) + +(def-type-prop-test logior.1 'logior '(integer integer) 2) +(def-type-prop-test logior.2 'logior nil 2 :rest-type 'integer :maxargs 6) + +(def-type-prop-test logxor.1 'logxor '(integer integer) 2) +(def-type-prop-test logxor.2 'logxor nil 2 :rest-type 'integer :maxargs 6) + +(def-type-prop-test logorc1 'logorc1 '(integer integer) 2) +(def-type-prop-test logorc2 'logorc2 '(integer integer) 2) + +(def-type-prop-test lognot 'lognot '(integer) 1) + +(def-type-prop-test logbitp.1 'logbitp '((integer 0 32) integer) 2) +(def-type-prop-test logbitp.2 'logbitp '((integer 0 100) integer) 2) +; (def-type-prop-test logbitp.3 'logbitp '((integer 0) integer) 2) + +(def-type-prop-test logcount 'logcount '(integer) 1) +(def-type-prop-test logtest 'logtest '(integer integer) 2) + +(def-type-prop-test decode-float.1 'decode-float '(float) 1) +(def-type-prop-test decode-float.2 '(lambda (x) (nth-value 1 (decode-float x))) '(float) 1) +(def-type-prop-test decode-float.3 '(lambda (x) (nth-value 2 (decode-float x))) '(float) 1) +(def-type-prop-test float-radix 'float-radix '(float) 1) +(def-type-prop-test scale-float 'scale-float '(float (integer -30 30)) 2 :ignore 'arithmetic-error :test #'approx=) +(def-type-prop-test float-sign.1 'float-sign '(float) 1) +(def-type-prop-test float-sign.2 'float-sign '(float float) 2) +(def-type-prop-test float-digits 'float-digits '(float) 1) +(def-type-prop-test float-precision 'float-precision '(float) 1) +(def-type-prop-test integer-decode-float.1 'integer-decode-float '(float) 1) +(def-type-prop-test integer-decode-float.2 '(lambda (x) (nth-value 1 (integer-decode-float x))) '(float) 1) +(def-type-prop-test integer-decode-float.3 '(lambda (x) (nth-value 2 (integer-decode-float x))) '(float) 1) + + +(def-type-prop-test float.1 'float '(real) 1) +(def-type-prop-test float.2 'float '(real float) 2) +(def-type-prop-test floatp 'floatp '(t) 1) + +(defun has-nonzero-length (x) (> (length x) 0)) + +(def-type-prop-test parse-integer.1 'parse-integer + '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (satisfies has-nonzero-length))) + 1) + +(def-type-prop-test parse-integer.2 'parse-integer + `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (satisfies has-nonzero-length)) + (eql :start) + ,#'(lambda (x &rest rest) (declare (ignore rest)) + `(integer 0 (,(length x))))) + 3) + +(def-type-prop-test sxhash 'sxhash '(t) 1) diff --git a/random/random-type-prop-tests-04.lsp b/random/random-type-prop-tests-04.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b12aae407e0e8b6810d371e297df427da2e6060e --- /dev/null +++ b/random/random-type-prop-tests-04.lsp @@ -0,0 +1,107 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 6 21:44:41 2005 +;;;; Contains: Test that invoke the random type prop infrastructure, part 4 + +(in-package :cl-test) + +(defun char-or-same (c &rest args) + (declare (ignore args)) + (if (coin) `(eql ,c) 'character)) + +(eval-when (:load-toplevel :execute) (compile 'char-or-same)) + +(def-type-prop-test char=.1 'char= nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char=.2 'char= '(character character) 2) +(def-type-prop-test char=.3 'char= (list 'character #'char-or-same) 2) +(def-type-prop-test char=.4 'char= (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char=.5 'char= '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char/=.1 'char/= nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char/=.2 'char/= '(character character) 2) +(def-type-prop-test char/=.3 'char/= (list 'character #'char-or-same) 2) +(def-type-prop-test char/=.4 'char/= (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char/=.5 'char/= nil 2 :rest-type 'character :maxargs 6) + +(def-type-prop-test char<=.1 'char<= nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char<=.2 'char<= '(character character) 2) +(def-type-prop-test char<=.3 'char<= (list 'character #'char-or-same) 2) +(def-type-prop-test char<=.4 'char<= (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char<=.5 'char<= '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char>=.1 'char>= nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char>=.2 'char>= '(character character) 2) +(def-type-prop-test char>=.3 'char>= (list 'character #'char-or-same) 2) +(def-type-prop-test char>=.4 'char>= (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char>=.5 'char>= '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char<.1 'char< nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char<.2 'char< '(character character) 2) +(def-type-prop-test char<.3 'char< (list 'character #'char-or-same) 2) +(def-type-prop-test char<.4 'char< (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char<.5 'char< nil 2 :rest-type 'character :maxargs 6) + +(def-type-prop-test char>.1 'char> nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char>.2 'char> '(character character) 2) +(def-type-prop-test char>.3 'char> (list 'character #'char-or-same) 2) +(def-type-prop-test char>.4 'char> (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char>.5 'char> nil 2 :rest-type 'character :maxargs 6) + + +(def-type-prop-test char-equal.1 'char-equal nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-equal.2 'char-equal '(character character) 2) +(def-type-prop-test char-equal.3 'char-equal (list 'character #'char-or-same) 2) +(def-type-prop-test char-equal.4 'char-equal (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char-equal.5 'char-equal '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char-not-equal.1 'char-not-equal nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-not-equal.2 'char-not-equal '(character character) 2) +(def-type-prop-test char-not-equal.3 'char-not-equal (list 'character #'char-or-same) 2) +(def-type-prop-test char-not-equal.4 'char-not-equal (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char-not-equal.5 'char-not-equal nil 2 :rest-type 'character :maxargs 6) + +(def-type-prop-test char-not-greaterp.1 'char-not-greaterp nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-not-greaterp.2 'char-not-greaterp '(character character) 2) +(def-type-prop-test char-not-greaterp.3 'char-not-greaterp (list 'character #'char-or-same) 2) +(def-type-prop-test char-not-greaterp.4 'char-not-greaterp (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char-not-greaterp.5 'char-not-greaterp '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char-not-lessp.1 'char-not-lessp nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-not-lessp.2 'char-not-lessp '(character character) 2) +(def-type-prop-test char-not-lessp.3 'char-not-lessp (list 'character #'char-or-same) 2) +(def-type-prop-test char-not-lessp.4 'char-not-lessp (list 'character #'char-or-same #'char-or-same) 3) +(def-type-prop-test char-not-lessp.5 'char-not-lessp '(character) 3 :rest-type #'char-or-same :maxargs 6) + +(def-type-prop-test char-lessp.1 'char-lessp nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-lessp.2 'char-lessp '(character character) 2) +(def-type-prop-test char-lessp.3 'char-lessp (list 'character #'char-or-same) 2) +(def-type-prop-test char-lessp.4 'char-lessp (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char-lessp.5 'char-lessp nil 2 :rest-type 'character :maxargs 6) + +(def-type-prop-test char-greaterp.1 'char-greaterp nil 2 :rest-type 'base-char :maxargs 5) +(def-type-prop-test char-greaterp.2 'char-greaterp '(character character) 2) +(def-type-prop-test char-greaterp.3 'char-greaterp (list 'character #'char-or-same) 2) +(def-type-prop-test char-greaterp.4 'char-greaterp (list 'character 'character #'char-or-same) 3) +(def-type-prop-test char-greaterp.5 'char-greaterp nil 2 :rest-type 'character :maxargs 6) + +(defun length1-p (seq) (= (length seq) 1)) + +(def-type-prop-test character 'character '((or character (and (string 1) (satisfies length1-p)))) 1) +(def-type-prop-test characterp 'characterp '(t) 1) +(def-type-prop-test alpha-char-p 'alpha-char-p '(character) 1) +(def-type-prop-test alphanumericp 'alphanumericp '(character) 1) +(def-type-prop-test digit-char 'digit-char '((or (integer 0 36) (integer 0)) (integer 2 36)) 1 :maxargs 2) +(def-type-prop-test digit-char-p 'digit-char-p '(character) 1) +(def-type-prop-test graphic-char-p 'graphic-char-p '(character) 1) +(def-type-prop-test standard-char-p 'standard-char-p '(character) 1) +(def-type-prop-test char-upcase 'char-upcase '(character) 1) +(def-type-prop-test char-downcase 'char-downcase '(character) 1) +(def-type-prop-test upper-case-p 'upper-case-p '(character) 1) +(def-type-prop-test lower-case-p 'lower-case-p '(character) 1) +(def-type-prop-test both-case-p 'both-case-p '(character) 1) +(def-type-prop-test char-code 'char-code '(character) 1) +(def-type-prop-test char-int 'char-int '(character) 1) +(def-type-prop-test code-char 'code-char '((integer 0 #.char-code-limit)) 1) +(def-type-prop-test char-name 'char-name '(character) 1) +(def-type-prop-test name-char 'name-char '(string) 1) + diff --git a/random/random-type-prop-tests-05.lsp b/random/random-type-prop-tests-05.lsp new file mode 100644 index 0000000000000000000000000000000000000000..5ef8ee93554a63e4e82e918e8b472f245b188f3c --- /dev/null +++ b/random/random-type-prop-tests-05.lsp @@ -0,0 +1,528 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Mar 8 20:31:08 2005 +;;;; Contains: Random type prop tests, part 5 (Cons) + +(in-package :cl-test) + +(def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10) +(def-type-prop-test list.2 '(lambda (x) (car (list x))) '(t) 1) +(def-type-prop-test list.3 '(lambda (x y) (cdr (list x y))) '(t t) 2) +(def-type-prop-test list.4 '(lambda (x y z) (cadr (list x y z))) '(t t t) 3) +(def-type-prop-test list.5 '(lambda (x) (let ((z (list x))) (declare (dynamic-extent z)) (car z))) '(t) 1) + +(def-type-prop-test list* 'list* () 1 :rest-type t :maxargs 10) + +(def-type-prop-test null 'null '(t) 1) +(def-type-prop-test cons.1 'cons '(t t) 2) +(def-type-prop-test cons.2 '(lambda (x y) (car (cons y x))) '(t t) 2) +(def-type-prop-test cons.3 '(lambda (x y) (cdr (cons x y))) '(t t) 2) + +(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 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) +(def-type-prop-test cdr 'cdr '((cons t t)) 1) +(def-type-prop-test rest 'rest '((cons t t)) 1) +(def-type-prop-test caar 'caar '((cons (cons t t) t)) 1) +(def-type-prop-test cdar 'cdar '((cons (cons t t) t)) 1) +(def-type-prop-test cadr 'cadr '((cons t (cons t t))) 1) +(def-type-prop-test second 'second '((cons t (cons t t))) 1) +(def-type-prop-test cddr 'cddr '((cons t (cons t t))) 1) +(def-type-prop-test caaar 'caaar '((cons (cons (cons t t) t) t)) 1) +(def-type-prop-test cdaar 'cdaar '((cons (cons (cons t t) t) t)) 1) +(def-type-prop-test cadar 'cadar '((cons (cons t (cons t t)) t)) 1) +(def-type-prop-test cddar 'cddar '((cons (cons t (cons t t)) t)) 1) +(def-type-prop-test caadr 'caadr '((cons t (cons (cons t t) t))) 1) +(def-type-prop-test cdadr 'cdadr '((cons t (cons (cons t t) t))) 1) +(def-type-prop-test caddr 'caddr '((cons t (cons t (cons t t)))) 1) +(def-type-prop-test third 'third '((cons t (cons t (cons t t)))) 1) +(def-type-prop-test cdddr 'cdddr '((cons t (cons t (cons t t)))) 1) + +(def-type-prop-test caaaar'caaaar '((cons (cons (cons (cons t t) t) t) t)) 1) +(def-type-prop-test cdaaar 'cdaaar '((cons (cons (cons (cons t t) t) t) t)) 1) +(def-type-prop-test cadaar 'cadaar '((cons (cons (cons t (cons t t)) t) t)) 1) +(def-type-prop-test cddaar 'cddaar '((cons (cons (cons t (cons t t)) t) t)) 1) +(def-type-prop-test caadar 'caadar '((cons (cons t (cons (cons t t) t)) t)) 1) +(def-type-prop-test cdadar 'cdadar '((cons (cons t (cons (cons t t) t)) t)) 1) +(def-type-prop-test caddar 'caddar '((cons (cons t (cons t (cons t t))) t)) 1) +(def-type-prop-test cdddar 'cdddar '((cons (cons t (cons t (cons t t))) t)) 1) +(def-type-prop-test caaadr 'caaadr '((cons t (cons (cons (cons t t) t) t))) 1) +(def-type-prop-test cdaadr 'cdaadr '((cons t (cons (cons (cons t t) t) t))) 1) +(def-type-prop-test cadadr 'cadadr '((cons t (cons (cons t (cons t t)) t))) 1) +(def-type-prop-test cddadr 'cddadr '((cons t (cons (cons t (cons t t)) t))) 1) +(def-type-prop-test caaddr 'caaddr '((cons t (cons t (cons (cons t t) t)))) 1) +(def-type-prop-test cdaddr 'cdaddr '((cons t (cons t (cons (cons t t) t)))) 1) +(def-type-prop-test cadddr 'cadddr '((cons t (cons t (cons t (cons t t))))) 1) +(def-type-prop-test fourth 'fourth '((cons t (cons t (cons t (cons t t))))) 1) +(def-type-prop-test cddddr 'cddddr '((cons t (cons t (cons t (cons t t))))) 1) + +(def-type-prop-test fifth 'fifth '((cons t (cons t (cons t (cons t (cons t t)))))) 1) +(def-type-prop-test sixth 'sixth '((cons t (cons t (cons t (cons t (cons t (cons t t))))))) 1) +(def-type-prop-test seventh 'seventh '((cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))) 1) +(def-type-prop-test eighth 'eighth + '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))) + 1) +(def-type-prop-test ninth 'ninth + '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t)))))))))) + 1) +(def-type-prop-test tenth 'tenth + '((cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t (cons t t))))))))))) + 1) + +(def-type-prop-test pop '(lambda (x) (list (pop x) x)) '((cons t t)) 1) +(def-type-prop-test push '(lambda (x y) (list (push x y) x y)) '(t t) 2) + +(def-type-prop-test copy-tree.1 'copy-tree '((cons t t)) 1) +(def-type-prop-test copy-tree.2 'copy-tree '((cons (cons t t) (cons t t))) 1) +(def-type-prop-test copy-tree.3 'copy-tree '((cons t (cons (cons t (cons t t)) t))) 1) +(def-type-prop-test copy-tree.4 'copy-tree '(list) 1) + +(def-type-prop-test sublis.1 'sublis '((cons (cons symbol t) null) list) 2) +(def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2) +(def-type-prop-test sublis.3 'sublis '(null list) 2) +(def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list + (eql :key) + (or null (eql not) (eql ,#'not))) 4) +(def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4) +(def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) + +(def-type-prop-test subst.1 'subst '(t t t) 3) +(def-type-prop-test subst.2 'subst '(t t (cons t t)) 3) +(def-type-prop-test subst.3 'subst '(t t list) 3) +(def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3) +(def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t)) + (eql :key) + (or null (eql not) (eql ,#'not))) 5) +(def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5) +(def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5) +(def-type-prop-test subst.8 'subst `(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) + +(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 '(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 '(nil nil t nil nil nil nil)) + + +(def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3) +(def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) +(def-type-prop-test subst-if.3 'subst-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) + +(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 '(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) +(def-type-prop-test subst-if-not.3 'subst-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) + +(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 '(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) +(def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t) + #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) + '(eql :test) + `(or (eql equal) (eql ,#'equal))) + 4) +(def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x)))) + '(eql :test-not) '(eql eql)) + 4) + +(def-type-prop-test copy-list.1 'copy-list '(list) 1) +(def-type-prop-test copy-list.2 'copy-list '((cons t t)) 1) +(def-type-prop-test copy-list.3 'copy-list '((cons t (cons t (or t (cons t (or t (cons t t))))))) 1) + +(def-type-prop-test list-length.1 'list-length '(list) 1) +(def-type-prop-test list-length.2 'list-length '((cons t list)) 1) + +(def-type-prop-test listp 'listp '(t) 1) + +(def-type-prop-test make-list.1 'make-list '((integer 0 100)) 1) +(def-type-prop-test make-list.2 '(lambda (x) (length (make-list x))) '((integer 0 100)) 1) +(def-type-prop-test make-list.3 'make-list '((integer 0 100) (eql :initial-element) t) 3) + +(def-type-prop-test nth.1 'nth '((integer 0 12) list) 2) + +(def-type-prop-test endp.1 'endp '((or null (cons t t))) 1) + +(def-type-prop-test append.1 'append nil 1 :maxargs 10 :rest-type 'list) +(def-type-prop-test append.2 'append '(list t) 2) +(def-type-prop-test append.3 'append '(list list t) 3) +(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 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 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 nil)) + +(def-type-prop-test last.1 'last '(list) 1) +(def-type-prop-test last.2 'last '(list (integer 0 15)) 2) +(def-type-prop-test last.3 'last '((cons t (or t (cons t (or t (cons t t)))))) 1) +(def-type-prop-test last.4 'last '((cons t (or t (cons t (or t (cons t t))))) (integer 0 5)) 2) + +(def-type-prop-test ldiff.1 'ldiff '(list t) 2) +(def-type-prop-test ldiff.2 'ldiff (list 'list + #'(lambda (x) + (if (consp x) + `(or t (eql ,(nthcdr (random (length x)) x))) + t))) + 2) + +(def-type-prop-test tailp.1 'tailp '(t list) 2) +(def-type-prop-test tailp.2 'tailp (list t #'(lambda (x) (make-list-type (1+ (random 10)) `(eql ,x)))) 2) + +(def-type-prop-test nthcdr 'nthcdr '((integer 0 20) list) 2) + +(def-type-prop-test member.1 'member '(t list) 2) +(def-type-prop-test member.2 'member + (list t #'(lambda (x) (make-list-type (random 5) `(cons (eql ,x) ,(make-list-type (random 5)))))) + 2) +(def-type-prop-test member.3 'member `(t list (eql :key) (or (eql not) (eql ,#'not))) 4) +(def-type-prop-test member.4 'member `(t list (eql :test) (or (eql equalp) (eql ,#'equalp))) 4) +(def-type-prop-test member.5 'member `(t list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) +(def-type-prop-test member.6 'member `(t list (eql :allow-other-keys) (and t (not null)) (eql :foo) t) 6) + +(def-type-prop-test member-if.1 'member-if `((or (eql symbolp) (eql ,#'symbolp)) list) 2) +(def-type-prop-test member-if.2 'member-if + (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) + 2) +(def-type-prop-test member-if.3 'member-if + (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) + '(eql :key)`(or (eql 1-) (eql ,#'1-))) + 4) + +(def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2) +(def-type-prop-test member-if-not.2 'member-if-not + (list '(eql plusp) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10)))) + 2) +(def-type-prop-test member-if-not.3 'member-if-not + (list '(eql plusp) + #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) + '(eql :key) + `(or (eql 1-) (eql ,#'1-))) + 4) +(def-type-prop-test member-if-not.4 'member-if-not + `((eql identity) list + (eql :allow-other-keys) (and t (not null)) + (member :foo :bar #:xyz) t) + 6) + +(def-type-prop-test mapc.1 'mapc '((eql list)) 2 :rest-type 'list :maxargs 10) +(def-type-prop-test mapc.2 'mapc `((eql ,#'values)) 2 :rest-type 'list :maxargs 10) + +(def-type-prop-test mapcar.1 'mapcar '((eql list)) 2 :rest-type 'list :maxargs 10) +(def-type-prop-test mapcar.2 'mapcar `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) + +(def-type-prop-test maplist.1 'maplist '((eql list)) 2 :rest-type 'list :maxargs 10) +(def-type-prop-test maplist.2 'maplist `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) + +(def-type-prop-test mapl.1 'mapl '((eql list)) 2 :rest-type 'list :maxargs 10) +(def-type-prop-test mapl.2 'mapl `((eql ,#'vector)) 2 :rest-type 'list :maxargs 10) + +(def-type-prop-test mapcan.1 'mapcan '((eql list)) 2 :rest-type 'list :maxargs 10) + +(def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2) + +(def-type-prop-test acons 'acons + (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t))))) + 3) + +(def-type-prop-test assoc.1 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) +(def-type-prop-test assoc.2 'assoc + (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t))))) + 2) +(def-type-prop-test assoc.3 'assoc + (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))) + '(eql :key) `(or (eql not) (eql ,#'not))) + 4) +(def-type-prop-test assoc.4 'assoc + (list 'real + #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) + `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) + 4) + +(def-type-prop-test assoc-if.1 'assoc-if + (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) + (make-list-type (random 8) 'null '(or null (cons t t)))) + 2) +(def-type-prop-test assoc-if.2 'assoc-if + (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) + (make-list-type (random 8) 'null '(or null (cons real t))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + 2) + +(def-type-prop-test assoc-if-not.1 'assoc-if-not + (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) + (make-list-type (random 8) 'null '(or null (cons t t)))) + 2) +(def-type-prop-test assoc-if-not.2 'assoc-if-not + (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) + (make-list-type (random 8) 'null '(or null (cons real t))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + 2) + +(def-type-prop-test copy-alist 'copy-alist + (list #'(lambda () (make-list-type (random 10) 'null '(or null (cons t t))))) + 1) + +(def-type-prop-test pairlis.1 'pairlis + (list 'list #'(lambda (x) (make-list-type (length x) 'null t))) + 2) + +(def-type-prop-test pairlis.2 'pairlis + (list 'list #'(lambda (x) (make-list-type (length x) 'null t)) + #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) + 3) + +(def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) +(def-type-prop-test rassoc.2 'rassoc + (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x)))))) + 2) +(def-type-prop-test rassoc.3 'rassoc + (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))) + '(eql :key) `(or (eql not) (eql ,#'not))) + 4) +(def-type-prop-test rassoc.4 'rassoc + (list 'real + #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) + `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) + 4) + +(def-type-prop-test rassoc-if.1 'rassoc-if + (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) + (make-list-type (random 8) 'null '(or null (cons t t)))) + 2) +(def-type-prop-test rassoc-if.2 'rassoc-if + (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) + (make-list-type (random 8) 'null '(or null (cons t real))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + 2) + +(def-type-prop-test rassoc-if-not.1 'rassoc-if-not + (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) + (make-list-type (random 8) 'null '(or null (cons t t)))) + 2) +(def-type-prop-test rassoc-if-not.2 'rassoc-if-not + (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) + (make-list-type (random 8) 'null '(or null (cons t real))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + 2) + +;;; We don't use numbers or characters as indicators, since the test is EQ, +;;; which is not well-behaved on these types. + +(def-type-prop-test get-properties.1 'get-properties + (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) 'list) + 2) +(def-type-prop-test get-properties.2 'get-properties + (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) + #'(lambda (plist) (let ((len (length plist))) + (if (= len 0) '(cons t null) + (let ((ind (elt plist (* 2 (random (floor len 2)))))) + `(cons (eql ,ind) null)))))) + 2) + +(def-type-prop-test getf.1 'getf + (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) t) + 2) +(def-type-prop-test getf.2 'getf + (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) + #'(lambda (plist) (let ((len (length plist))) + (if (= len 0) t + (let ((ind (elt plist (* 2 (random (floor len 2)))))) + `(eql ,ind)))))) + 2) +(def-type-prop-test getf.3 'getf + (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) + t t) + 3) + +(def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p) +(def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p) +(def-type-prop-test intersection.3 'intersection + (list #'(lambda () (make-list-type (random 10) 'null 'integer)) + #'(lambda (x) (make-list-type (random 10) 'null 'integer)) + '(eql :key) + `(member 1+ ,#'1+)) + 4 + :test #'same-set-p) +(def-type-prop-test intersection.4 'intersection + (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :key) + `(member car ,#'car)) + 4 + :test #'(lambda (x y) (same-set-p x y :key #'car))) +(def-type-prop-test intersection.5 'intersection + (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :test) + `(member equal ,#'equal)) + 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 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)) + '(eql :key) + `(member 1+ ,#'1+)) + 4 + :test #'same-set-p + :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))) + '(eql :key) + `(member car ,#'car)) + 4 + :test #'(lambda (x y) (same-set-p x y :key #'car)) + :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))) + '(eql :test) + `(member equal ,#'equal)) + 4 + :test #'(lambda (x y) (same-set-p x y :key #'car)) + :replicate '(t t nil nil)) + + +(def-type-prop-test adjoin.1 'adjoin '(t list) 2) +(def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2) +(def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null))) + (eql :test) (or (eql =) (eql ,#'=))) + 4) +(def-type-prop-test adjoin.4 'adjoin `(number + (cons number (cons number (cons number (cons number null)))) + (eql :test-not) (or (eql /=) (eql ,#'/=))) + 4) +(def-type-prop-test adjoin.5 'adjoin `(number + (cons number (cons number (cons number (cons number null)))) + (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) + 4) + +(def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2) +(def-type-prop-test pushnew.2 '(lambda (x y) (list (pushnew x y) y)) '((integer 0 1) list) 2) +(def-type-prop-test pushnew.3 '(lambda (x y) (list (pushnew x y :test #'=) y)) + `((integer 0 10) (cons number (cons number (cons number null)))) + 2) +(def-type-prop-test pushnew.4 '(lambda (x y) (list (pushnew x y :test-not #'/=) y)) + `((integer 0 10) (cons number (cons number (cons number null)))) + 2) +(def-type-prop-test pushnew.5 '(lambda (x y) (list (pushnew x y :key #'1+) y)) + `(number (cons number (cons number (cons number (cons number null))))) + 2) + +(def-type-prop-test set-difference.1 'set-difference '(list list) 2) +(def-type-prop-test set-difference.2 'set-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) +(def-type-prop-test set-difference.3 'set-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) +(def-type-prop-test set-difference.4 'set-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) +(def-type-prop-test set-difference.5 'set-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) + +(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 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 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 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 t nil nil)) + + +(def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2) +(def-type-prop-test set-exclusive-or.2 'set-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) +(def-type-prop-test set-exclusive-or.3 'set-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) +(def-type-prop-test set-exclusive-or.4 'set-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) +(def-type-prop-test set-exclusive-or.5 'set-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) + +(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 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 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 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 t nil nil)) + +(def-type-prop-test subsetp.1 'subsetp '(list list) 2) +(def-type-prop-test subsetp.2 'subsetp '((cons integer null) + (cons integer (cons integer (cons integer (cons integer null))))) + 2) diff --git a/random/random-type-prop-tests-06.lsp b/random/random-type-prop-tests-06.lsp new file mode 100644 index 0000000000000000000000000000000000000000..b90f9d05fc4b831e9eafd114e32049fc5b079f3f --- /dev/null +++ b/random/random-type-prop-tests-06.lsp @@ -0,0 +1,146 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 13 15:33:55 2005 +;;;; Contains: Random type prop tests, part 6 (arrays) + +(in-package :cl-test) + +(def-type-prop-test adjustable-array-p 'adjustable-array-p '(array) 1) + +(def-type-prop-test aref.0 'aref '((array * nil)) 1) +(def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2) +(def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) +(def-type-prop-test aref.3 'aref (list '(array * (* * *)) + (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + 4) + +(def-type-prop-test array-dimension 'array-dimension + (list 'array #'(lambda (x) (let ((r (array-rank x))) (and (> r 0) `(integer 0 (,r)))))) + 2) +(def-type-prop-test array-dimensions 'array-dimensions '(array) 1) +(def-type-prop-test array-element-type 'array-element-type '(array) 1) +(def-type-prop-test array-has-fill-pointer-p.1 'array-has-fill-pointer-p '(array) 1) +(def-type-prop-test array-has-fill-pointer-p.2 'array-has-fill-pointer-p '(vector) 1) +(def-type-prop-test array-displacement.1 'array-displacement '(array) 1) +(def-type-prop-test array-displacement.2 'array-displacement '(vector) 1) + +(def-type-prop-test array-in-bounds-p.0 'array-in-bounds-p '((array * nil)) 1) +(def-type-prop-test array-in-bounds-p.1 'array-in-bounds-p (list '(array * (*)) (index-type-for-dim 0)) 2) +(def-type-prop-test array-in-bounds-p.2 'array-in-bounds-p + (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) +(def-type-prop-test array-in-bounds-p.3 'array-in-bounds-p + (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + 4) +(def-type-prop-test array-in-bounds-p.4 'array-in-bounds-p '((array * (*)) integer) 2) +(def-type-prop-test array-in-bounds-p.5 'array-in-bounds-p '((array * (* *)) integer integer) 3) +(def-type-prop-test array-in-bounds-p.6 'array-in-bounds-p '((array * (* * *)) integer integer integer) 4) +(def-type-prop-test array-rank 'array-rank '(array) 1) + +(def-type-prop-test array-row-major-index.0 'array-row-major-index '((array * nil)) 1) +(def-type-prop-test array-row-major-index.1 'array-row-major-index (list '(array * (*)) (index-type-for-dim 0)) 2) +(def-type-prop-test array-row-major-index.2 'array-row-major-index + (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) +(def-type-prop-test array-row-major-index.3 'array-row-major-index + (list '(array * (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + 4) +(def-type-prop-test array-total-size 'array-total-size '(array) 1) + +(def-type-prop-test arrayp 'arrayp '(t) 1) + +(def-type-prop-test fill-pointer '(lambda (x) (and (array-has-fill-pointer-p x) (fill-pointer x))) '(vector) 1) + +(def-type-prop-test row-major-aref 'row-major-aref + (list 'array #'(lambda (a) (let ((s (array-total-size a))) (and (> s 0) `(integer 0 (,s)))))) + 2) + +(def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type + (list #'(lambda () (let ((x (make-random-element-of-type t))) + `(eql ,(make-random-type-containing x))))) + 1) + +(def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1) +(def-type-prop-test simple-vector-p.2 'simple-vector-p '(vector) 1) + +(def-type-prop-test svref 'svref (list 'simple-vector (index-type-for-dim 0)) 2) +(def-type-prop-test vector 'vector nil 1 :rest-type t :maxargs 10) +(def-type-prop-test vectorp.1 'vectorp '(t) 1) +(def-type-prop-test vectorp.2 'vectorp '(array) 1) + +(def-type-prop-test bit.1 'bit (list '(array bit (*)) (index-type-for-dim 0)) 2) +(def-type-prop-test bit.2 'bit (list '(array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) +(def-type-prop-test bit.3 'bit + (list '(array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + 4) + +(def-type-prop-test sbit.1 'sbit (list '(simple-array bit (*)) (index-type-for-dim 0)) 2) +(def-type-prop-test sbit.2 'sbit (list '(simple-array bit (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) +(def-type-prop-test sbit.3 'sbit + (list '(simple-array bit (* * *)) (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + 4) + + +(def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-and.2 'bit-and + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-andc1.2 'bit-andc1 + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-andc2.2 'bit-andc2 + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-ior.2 'bit-ior + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-orc1.2 'bit-orc1 + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-orc2.2 'bit-orc2 + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-eqv.2 'bit-eqv + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-xor.2 'bit-xor + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-nand.2 'bit-nand + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) + `(array bit ,dims)))) + 2) +(def-type-prop-test bit-nor.2 'bit-nor + (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) + 3) +(def-type-prop-test bit-not.1 'bit-not '((array bit)) 1) +(def-type-prop-test bit-not.2 'bit-not '((array bit) null) 2) + +(def-type-prop-test bit-vector-p 'bit-vector-p '(t) 1) +(def-type-prop-test simple-bit-vector-p 'simple-bit-vector-p '(t) 1) diff --git a/random/random-type-prop-tests-07.lsp b/random/random-type-prop-tests-07.lsp new file mode 100644 index 0000000000000000000000000000000000000000..efe6f59b1e92cf91e2f91d854e8f0a436e6e9756 --- /dev/null +++ b/random/random-type-prop-tests-07.lsp @@ -0,0 +1,121 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 13 17:03:52 2005 +;;;; Contains: Random type prop tests, part 7 (strings) + +(in-package :cl-test) + +(def-type-prop-test simple-string-p 'simple-string-p '(t) 1) +(def-type-prop-test char 'char (list 'string (index-type-for-dim 0)) 2) +(def-type-prop-test schar 'schar (list 'simple-string (index-type-for-dim 0)) 2) + +(def-type-prop-test string 'string '((or string symbol character)) 1) +(def-type-prop-test string-upcase 'string-upcase '(string) 1) +(def-type-prop-test string-downcase 'string-downcase '(string) 1) +(def-type-prop-test string-capitalize 'string-capitalize '(string) 1) + +(def-type-prop-test string-trim.1 'string-trim '(string string) 2) +(def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) + 'string) + 2) +(def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2) +(def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) + 'string) + 2) +(def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2) +(def-type-prop-test string-right-trim.2 'string-right-trim + (list #'(lambda () (make-list-type (random 10) 'null 'character)) 'string) + 2) + +(defmacro def-string-comparison-type-prop-test (op) + (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test))) + `(progn + (def-type-prop-test ,(%makename 1) ',op '(string string) 2) + (def-type-prop-test ,(%makename 2) ',op + `(string string (eql :start1) ,#'index-type-for-v1) + 4) + (def-type-prop-test ,(%makename 3) ',op + `(string string (eql :start2) ,#'index-type-for-v2) + 4) + (def-type-prop-test ,(%makename 4) ',op + `(string string (eql :end1) ,#'end-type-for-v1) + 4) + (def-type-prop-test ,(%makename 5) ',op + `(string string (eql :end2) ,#'end-type-for-v2) + 4) + (def-type-prop-test ,(%makename 6) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end1) ,#'end-type-for-v1) + 6) + (def-type-prop-test ,(%makename 7) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end2) ,#'end-type-for-v2) + 6) + (def-type-prop-test ,(%makename 8) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 6) + (def-type-prop-test ,(%makename 9) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2) + 6) + (def-type-prop-test ,(%makename 10) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 11) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2) + 8) + (def-type-prop-test ,(%makename 12) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 13) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 14) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 10) + ))) + +(def-string-comparison-type-prop-test string=) +(def-string-comparison-type-prop-test string/=) +(def-string-comparison-type-prop-test string<) +(def-string-comparison-type-prop-test string<=) +(def-string-comparison-type-prop-test string>) +(def-string-comparison-type-prop-test string>=) + +(def-string-comparison-type-prop-test string-equal) +(def-string-comparison-type-prop-test string-not-equal) +(def-string-comparison-type-prop-test string-lessp) +(def-string-comparison-type-prop-test string-greaterp) +(def-string-comparison-type-prop-test string-not-lessp) +(def-string-comparison-type-prop-test string-not-greaterp) + +(def-type-prop-test stringp 'stringp '(t) 1) + +(def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3) +(def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character + (eql :element-type) + ,#'(lambda (&rest args) + `(eql (and character + ,(make-random-type-containing (third args)))))) + 5) diff --git a/random/random-type-prop-tests-08.lsp b/random/random-type-prop-tests-08.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9f8c938cd7fbc40bc17f6bb70515fa3d973e6bdc --- /dev/null +++ b/random/random-type-prop-tests-08.lsp @@ -0,0 +1,348 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Mar 13 18:31:57 2005 +;;;; Contains: Random type prop tests, part 8 (sequences) + +(in-package :cl-test) + +(def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1) + +(def-type-prop-test elt 'elt (list '(or vector list) + #'(lambda (x) (let ((len (length x))) + (and (> len 0) `(integer 0 (,len)))))) + 2) + +(defmacro rfill (x y &rest other-args) + `(fill ,y ,x ,@other-args)) + +(def-type-prop-test fill.1 'rfill + (list t #'make-random-sequence-type-containing) + 2 :replicate '(nil t)) + +(def-type-prop-test fill.2 'rfill + (list 'integer #'make-random-sequence-type-containing) + 2 :replicate '(nil t)) + +(def-type-prop-test fill.3 'rfill + (list 'character #'make-random-sequence-type-containing) + 2 :replicate '(nil t)) + +(def-type-prop-test fill.4 'rfill + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4 :replicate '(nil t nil nil)) + +(def-type-prop-test fill.5 'rfill + (list t #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4 :replicate '(nil t nil nil)) + +(def-type-prop-test fill.6 'rfill + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6 :replicate '(nil t nil nil nil nil)) + +;;; make-sequence tests here + +(def-type-prop-test subseq.1 'subseq + (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) + 2) + +(def-type-prop-test subseq.2 'subseq + (list 'sequence #'(lambda (s) `(integer 0 ,(length s))) + #'(lambda (s start) `(integer ,start ,(length s)))) + 3) + +;;; map tests here + +(def-type-prop-test map.1 'map + (list '(member list vector) + '(member list #.#'list) + '(or list vector)) + 3) + +(def-type-prop-test map.2 'map + (list '(member list vector) + '(member list #.#'list) + '(or list vector) + '(or list vector)) + 4) + +(def-type-prop-test map.3 'map + (list '(member list vector) + '(member list #.#'list) + '(or list vector) + '(or list vector) + '(or list vector)) + 5) + +(def-type-prop-test map.4 'map + (list '(member list vector (vector (unsigned-byte 32))) + '(member 1+ #.#'1+) + `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) + 3) + +(def-type-prop-test map.5 'map + (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i)))) + '(member 1+ #.#'1+) + #'(lambda (type fun) + (declare (ignore fun)) + (let ((i (cadadr type))) + `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) + 3) + + + +;;; map-into tests here + +(def-type-prop-test map-into.1 'map-into + (list '(or list (vector t)) + '(member list #.#'list) + '(or list vector)) + 3 :replicate '(t nil nil)) + +(def-type-prop-test map-into.2 'map-into + (list '(or list (vector t)) + '(member list #.#'list) + '(or list vector) + '(or list vector)) + 4 :replicate '(t nil nil nil)) + +;;; reduce tests here + +(def-type-prop-test count.1 'count '(t sequence) 2) +(def-type-prop-test count.2 'count + (list t #'make-random-sequence-type-containing) + 2) +(def-type-prop-test count.3 'count + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s)))) + 4) +(def-type-prop-test count.4 'count + (list t #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s)))) + 4) +(def-type-prop-test count.5 'count + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s))) + '(eql :end) + #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) + `(integer ,start ,(length s)))) + 6) + +(def-type-prop-test count.6 'count + (list '(or short-float single-float double-float long-float) + #'(lambda (f) `(vector (or ,(typecase f + (short-float 'short-float) + (single-float 'single-float) + (double-float 'double-float) + (long-float 'long-float) + (t 'float)) + (eql ,f))))) + 2) + +(def-type-prop-test count.7 'count '(bit (vector bit)) 2) +(def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2) +(def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2) +(def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2) + + +;;; count-if tests + +(def-type-prop-test count-if.1 'count-if + (list (let ((funs '(numberp rationalp realp floatp complexp + symbolp identity null functionp listp consp + arrayp vectorp simple-vector-p + stringp simple-string-p + bit-vector-p simple-bit-vector-p))) + `(member ,@funs ,@(mapcar #'symbol-function funs))) + '(or list vector)) + 2) + +(def-type-prop-test count-if.2 'count-if + (list (let ((funs '(numberp rationalp realp floatp complexp + symbolp identity null functionp listp consp + arrayp vectorp simple-vector-p + stringp simple-string-p + bit-vector-p simple-bit-vector-p))) + `(member ,@funs ,@(mapcar #'symbol-function funs))) + '(or list vector) + '(eql :key) + (let ((key-funs '(identity not null))) + `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) + 4) + + +;;; Put count-if-not tests here + + +(def-type-prop-test length.1 'length '(sequence) 1) + +(def-type-prop-test reverse.1 'reverse '(sequence) 1) +(def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t)) + +(def-type-prop-test sort.1 'sort + `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 + :replicate '(t nil)) + +(def-type-prop-test sort.2 'sort + `((or (vector (unsigned-byte 2)) + (vector (unsigned-byte 3)) + (vector (unsigned-byte 4)) + (vector (unsigned-byte 5)) + (vector (unsigned-byte 6)) + (vector (unsigned-byte 7)) + (vector (unsigned-byte 8))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.3 'sort + `((or (vector (unsigned-byte 10)) + (vector (unsigned-byte 13)) + (vector (unsigned-byte 15)) + (vector (unsigned-byte 16))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.4 'sort + `((or (vector (unsigned-byte 20)) + (vector (unsigned-byte 24)) + (vector (unsigned-byte 28)) + (vector (unsigned-byte 31)) + (vector (unsigned-byte 32))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.5 'sort + `((or (vector (signed-byte 2)) + (vector (signed-byte 3)) + (vector (signed-byte 4)) + (vector (signed-byte 5)) + (vector (signed-byte 6)) + (vector (signed-byte 7)) + (vector (signed-byte 8))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.6 'sort + `((or (vector (signed-byte 10)) + (vector (signed-byte 13)) + (vector (signed-byte 15)) + (vector (signed-byte 16))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.7 'sort + `((or (vector (signed-byte 20)) + (vector (signed-byte 24)) + (vector (signed-byte 28)) + (vector (signed-byte 31)) + (vector (signed-byte 32))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test sort.8 'sort + `((or (vector short-float) + (vector single-float) + (vector double-float) + (vector long-float)) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +;;; Stable sort + +(def-type-prop-test stable-sort.1 'stable-sort + `((vector bit) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 + :replicate '(t nil)) + +(def-type-prop-test stable-sort.2 'stable-sort + `((or (vector (unsigned-byte 2)) + (vector (unsigned-byte 3)) + (vector (unsigned-byte 4)) + (vector (unsigned-byte 5)) + (vector (unsigned-byte 6)) + (vector (unsigned-byte 7)) + (vector (unsigned-byte 8))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.3 'stable-sort + `((or (vector (unsigned-byte 10)) + (vector (unsigned-byte 13)) + (vector (unsigned-byte 15)) + (vector (unsigned-byte 16))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.4 'stable-sort + `((or (vector (unsigned-byte 20)) + (vector (unsigned-byte 24)) + (vector (unsigned-byte 28)) + (vector (unsigned-byte 31)) + (vector (unsigned-byte 32))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.5 'stable-sort + `((or (vector (signed-byte 2)) + (vector (signed-byte 3)) + (vector (signed-byte 4)) + (vector (signed-byte 5)) + (vector (signed-byte 6)) + (vector (signed-byte 7)) + (vector (signed-byte 8))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.6 'stable-sort + `((or (vector (signed-byte 10)) + (vector (signed-byte 13)) + (vector (signed-byte 15)) + (vector (signed-byte 16))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.7 'stable-sort + `((or (vector (signed-byte 20)) + (vector (signed-byte 24)) + (vector (signed-byte 28)) + (vector (signed-byte 31)) + (vector (signed-byte 32))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.8 'stable-sort + `((or (vector short-float) + (vector single-float) + (vector double-float) + (vector long-float)) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) + 2 :replicate '(t nil)) + +(def-type-prop-test stable-sort.9 'stable-sort + `((vector (cons (integer 0 4) (eql nil))) + (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=) + (eql :key) + (member car ,#'car)) + 4 :replicate '(t nil nil nil) + :test #'equalp-and-eql-elements) diff --git a/random/random-type-prop-tests-09.lsp b/random/random-type-prop-tests-09.lsp new file mode 100644 index 0000000000000000000000000000000000000000..46270c318e133c091ca73a0ece40c94eebb6df36 --- /dev/null +++ b/random/random-type-prop-tests-09.lsp @@ -0,0 +1,717 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Random type prop tests, part 9 (sequences) + +(in-package :cl-test) + +;;; FIND + +(def-type-prop-test find.1 'find + (list t #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test find.2 'find + (list 'integer #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test find.3 'find + (list 'character #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test find.4 'find + (list t + #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find.5 'find + (list t + #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find.6 'find + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test find.7 'find + (list 'integer #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real number)))) + '(eql :key) + '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) + 4) + +(def-type-prop-test find.8 'find + (list 'character + #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(character base-char standard-char)))) + '(eql :key) + '(member char-upcase #.#'char-upcase + char-downcase #.#'char-downcase + upper-case-p #.#'upper-case-p + lower-case-p #.#'lower-case-p + both-case-p #.#'both-case-p + char-code #.#'char-code + char-int #.#'char-int + alpha-char-p #.#'alpha-char-p + digit-char-p #.#'digit-char-p + alphanumericp #.#'alphanumericp)) + 4) + +(def-type-prop-test find.9 'find + (list t #'make-random-sequence-type-containing + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test find.10 'find + (list 'real #'(lambda (x) (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real)))) + '(eql :from-end) + '(or null t) + '(member :test :test-not) + (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= + 'equal #'equal 'eql #'eql)) + 6) + +;;; FIND-IF + +(def-type-prop-test find-if.1 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence) + 2) + +(def-type-prop-test find-if.2 'find-if + (list + (let ((char-predicates + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) + (append '(member) char-predicates + (mapcar #'symbol-function char-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + '(or standard-char base-char character)))) + 2) + +(def-type-prop-test find-if.3 'find-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) + 2) + +(def-type-prop-test find-if.4 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find-if.5 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find-if.6 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (f s k1 start k2) + (declare (ignore f k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test find-if.7 'find-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :key) + (list 'member '1+ '1- 'identity '- + #'1+ #'1- #'identity #'-)) + 4) + +(def-type-prop-test find-if.8 'find-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test find-if.9 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +(def-type-prop-test find-if.10 'find-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +;;; FIND-IF-NOT + +(def-type-prop-test find-if-not.1 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence) + 2) + +(def-type-prop-test find-if-not.2 'find-if-not + (list + (let ((char-predicates + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) + (append '(member) char-predicates + (mapcar #'symbol-function char-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + '(or standard-char base-char character)))) + 2) + +(def-type-prop-test find-if-not.3 'find-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) + 2) + +(def-type-prop-test find-if-not.4 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find-if-not.5 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test find-if-not.6 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (f s k1 start k2) + (declare (ignore f k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test find-if-not.7 'find-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :key) + (list 'member '1+ '1- 'identity '- + #'1+ #'1- #'identity #'-)) + 4) + +(def-type-prop-test find-if-not.8 'find-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test find-if-not.9 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +(def-type-prop-test find-if-not.10 'find-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +;;; POSITION + +(def-type-prop-test position.1 'position + (list t #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test position.2 'position + (list 'integer #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test position.3 'position + (list 'character #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test position.4 'position + (list t + #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position.5 'position + (list t + #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position.6 'position + (list t #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test position.7 'position + (list 'integer #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real number)))) + '(eql :key) + '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) + 4) + +(def-type-prop-test position.8 'position + (list 'character + #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(character base-char standard-char)))) + '(eql :key) + '(member char-upcase #.#'char-upcase + char-downcase #.#'char-downcase + upper-case-p #.#'upper-case-p + lower-case-p #.#'lower-case-p + both-case-p #.#'both-case-p + char-code #.#'char-code + char-int #.#'char-int + alpha-char-p #.#'alpha-char-p + digit-char-p #.#'digit-char-p + alphanumericp #.#'alphanumericp)) + 4) + +(def-type-prop-test position.9 'position + (list t #'make-random-sequence-type-containing + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test position.10 'position + (list 'real #'(lambda (x) (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real)))) + '(eql :from-end) + '(or null t) + '(member :test :test-not) + (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= + 'equal #'equal 'eql #'eql)) + 6) + +;;; POSITION-IF + +(def-type-prop-test position-if.1 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence) + 2) + +(def-type-prop-test position-if.2 'position-if + (list + (let ((char-predicates + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) + (append '(member) char-predicates + (mapcar #'symbol-function char-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + '(or standard-char base-char character)))) + 2) + +(def-type-prop-test position-if.3 'position-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) + 2) + +(def-type-prop-test position-if.4 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position-if.5 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position-if.6 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (f s k1 start k2) + (declare (ignore f k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test position-if.7 'position-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :key) + (list 'member '1+ '1- 'identity '- + #'1+ #'1- #'identity #'-)) + 4) + +(def-type-prop-test position-if.8 'position-if + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test position-if.9 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +(def-type-prop-test position-if.10 'position-if + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +;;; POSITION-IF-NOT + +(def-type-prop-test position-if-not.1 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence) + 2) + +(def-type-prop-test position-if-not.2 'position-if-not + (list + (let ((char-predicates + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) + (append '(member) char-predicates + (mapcar #'symbol-function char-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + '(or standard-char base-char character)))) + 2) + +(def-type-prop-test position-if-not.3 'position-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) + 2) + +(def-type-prop-test position-if-not.4 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position-if-not.5 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test position-if-not.6 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (f s k1 start k2) + (declare (ignore f k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) + 6) + +(def-type-prop-test position-if-not.7 'position-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :key) + (list 'member '1+ '1- 'identity '- + #'1+ #'1- #'identity #'-)) + 4) + +(def-type-prop-test position-if-not.8 'position-if-not + (list + (let ((integer-predicates '(zerop plusp minusp evenp oddp))) + (append '(member) integer-predicates + (mapcar #'symbol-function integer-predicates))) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type (random 10) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) + '(eql :from-end) + '(or null t)) + 4) + +(def-type-prop-test position-if-not.9 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :start) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) + +(def-type-prop-test position-if-not.10 'position-if-not + (list + (append '(member) *cl-safe-predicates* + (mapcar 'symbol-function *cl-safe-predicates*)) + 'sequence + '(eql :end) + #'(lambda (f s k1) (declare (ignore f k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :from-end) + '(or null t)) + 6) diff --git a/random/random-type-prop-tests-10.lsp b/random/random-type-prop-tests-10.lsp new file mode 100644 index 0000000000000000000000000000000000000000..71d23474ad7e02084b378c457ac2b8eb904b7f5e --- /dev/null +++ b/random/random-type-prop-tests-10.lsp @@ -0,0 +1,114 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Contains: Random type prop tests, part 10 (sequences, cont.) + +(in-package :cl-test) + +;;; SEARCH + +(def-type-prop-test search.1 'search + (list 'sequence 'sequence) + 2) + +(def-type-prop-test search.2 'search + (list 'bit-vector 'bit-vector) + 2) + +(def-type-prop-test search.3 'search + (list '(vector * 1) 'sequence) + 2) + +(def-type-prop-test search.4 'search + (list '(vector * 2) 'sequence '(eql :from-end) '(or null t)) + 4) + +(def-type-prop-test search.5 'search + (list 'sequence 'sequence '(eql :key) + (list 'member 'identity nil #'identity 'not #'not)) + 4) + +(def-type-prop-test search.6 'search + (list #'(lambda () (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + #'(lambda (s) + (declare (ignore s)) + (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2)))))) + 2) + +(def-type-prop-test search.7 'search + (list #'(lambda () (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + #'(lambda (s) + (declare (ignore s)) + (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + '(eql :test) + (list 'member 'eql #'eql 'equal #'equal '= #'= + '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) + 4) + +(def-type-prop-test search.8 'search + (labels ((%random-char-type () (random-from-seq #(base-char standard-char character))) + (%random-char-sequence-type (&rest ignored) + (declare (ignore ignored)) + (make-sequence-type (random 10) (%random-char-type)))) + + (list #'%random-char-sequence-type + #'%random-char-sequence-type + '(member :test :test-not) + (let ((char-compare-funs + '(char= char/= char< char> char<= char>= + char-equal char-not-equal char-lessp char-greaterp + char-not-lessp char-not-greaterp))) + `(member ,@char-compare-funs + ,@(mapcar #'symbol-function char-compare-funs))))) + 4) + +(def-type-prop-test search.9 'search + (list 'sequence 'sequence + '(eql :start1) + #'(lambda (s1 s2 k) + (declare (ignore s2 k)) + (let ((len (length s1))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test search.10 'search + (list 'sequence 'sequence + '(eql :end1) + #'(lambda (s1 s2 k) + (declare (ignore s2 k)) + (let ((len (length s1))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test search.11 'search + (list 'sequence 'sequence + '(eql :start2) + #'(lambda (s1 s2 k) + (declare (ignore s1 k)) + (let ((len (length s2))) + `(integer 0 ,len)))) + 4) + +(def-type-prop-test search.12 'search + (list 'sequence 'sequence + '(eql :end2) + #'(lambda (s1 s2 k) + (declare (ignore s1 k)) + (let ((len (length s2))) + `(integer 0 ,len)))) + 4) diff --git a/random/random-type-prop-tests-structs.lsp b/random/random-type-prop-tests-structs.lsp new file mode 100644 index 0000000000000000000000000000000000000000..9a4423ad968c6274baff3fb505d98f4a87c9a611 --- /dev/null +++ b/random/random-type-prop-tests-structs.lsp @@ -0,0 +1,72 @@ +;-*- 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) + +(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) + diff --git a/random/random-type-prop-tests.lsp b/random/random-type-prop-tests.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6f86d1c75ed07c5fefb033221637f4ee79255678 --- /dev/null +++ b/random/random-type-prop-tests.lsp @@ -0,0 +1,22 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Feb 20 11:50:26 2005 +;;;; Contains: Randomized tests of type propagation during compilation + +(compile-and-load "random-type-prop.lsp") + +(in-package :cl-test) + +(load "random-type-prop-tests-01.lsp") +(load "random-type-prop-tests-02.lsp") +(load "random-type-prop-tests-03.lsp") +(load "random-type-prop-tests-04.lsp") +(load "random-type-prop-tests-05.lsp") +(load "random-type-prop-tests-06.lsp") +(load "random-type-prop-tests-07.lsp") +(load "random-type-prop-tests-08.lsp") +(load "random-type-prop-tests-09.lsp") +(load "random-type-prop-tests-10.lsp") + +(load "random-type-prop-tests-structs.lsp") + diff --git a/random/random-type-prop.lsp b/random/random-type-prop.lsp new file mode 100644 index 0000000000000000000000000000000000000000..bacb02cf00065a4de6a01f621aa58c95202191ec --- /dev/null +++ b/random/random-type-prop.lsp @@ -0,0 +1,664 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Dec 23 20:39:22 2004 +;;;; Contains: Randomized tests of type propagation in the compiler + +(in-package :cl-test) + +(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) + +(declaim (special *param-types* *params* *is-var?* *form*)) +(declaim (special *replicate-type*)) + +(defparameter *default-reps* 1000) +(defparameter *default-cell* nil) +(defparameter *default-ignore* 'arithmetic-error) +(defparameter *default-arg-the* t) + +;;; +;;; The random type prop tester takes three required arguments: +;;; +;;; operator A lisp operator (either a symbol or a lambda form) +;;; arg-types A list consisting either of certain kinds of lisp types +;;; (that make-random-element-of-type understands) and/or +;;; functions that yield types. +;;; minargs Minimum number of arguments to be given to the operator. +;;; Must be a positive integer <= maxargs. +;;; +;;; There are also keyword arguments, some with defaults given by special +;;; variables. +;;; +;;; The random type prop tester generates between minargs and maxargs +;;; (maxargs defaults to minargs) random arguments. The type of each +;;; argument is given by the corresponding type in arg-types (or by rest-type, +;;; if there aren't enough elements of arg-types). If the element of arg-types +;;; is a function, the type for the parameter is produced by calling the function +;;; with the previously generated actual parameters as its arguments. +;;; +;;; The list of parameters is stored into the special variable *params*. +;;; +;;; The tester evaluates (operator . arguments), and also builds a lambda +;;; form to be compiled and called on (a subset of) the parameters. The lambda +;;; form is stored in the special variable *form*. +;;; +;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests +;;; in a deftest form. See random-type-prop-tests.lsp (and subfiles) for examples +;;; of its use testing CL builtin operators. To use it: +;;; +;;; (load "gclload1.lsp") +;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles +;;; (compile-and-load "random-type-prop.lsp") +;;; (in-package :cl-test) +;;; (load "random-type-prop-tests.lsp") +;;; (let (*catch-errors*) (do-test '<testname>)) +;;; or (let (*catch-errors*) (do-tests)) +;;; +;;; Running all the tests may take a while, particularly on lisps with slow compilers. +;;; +;;; +;;; Keyword arguments to do-random-type-prop-tests: +;;; +;;; Argument Default Meaning +;;; +;;; maxargs minargs Maximum number of actual parameters to generate (max 20). +;;; rest-type t Type of arguments beyond those specified in arg-types +;;; reps *default-reps* Number of repetitions to try before stopping. +;;; The default is controlled by a special variable that +;;; is initially 1000. +;;; enclosing-the nil If true, with prob 1/2 randomly generate an enclosing +;;; (THE ...) form around the form invoking the operator. +;;; arg-the *default-arg-the* If true (which is the initial value of the default +;;; special variable), with probability 1/2 randomly generate +;;; a (THE ...) form around each actual parameter. +;;; cell *default-cell* If true (default is NIL), store the result into a rank-0 +;;; array of specialized type. This enables one to test +;;; forms where the result will be unboxed. Otherwise, just +;;; return the values. +;;; ignore *default-ignore* Ignore conditions that are elements of IGNORE. Default is +;;; ARITHMETIC-ERROR. +;;; test rt::equalp-with-case The test function used to compare outputs. It's +;;; also handy to use #'approx= to handle approximate equality +;;; when testing floating point computations, where compiled code +;;; may have different roundoff errors. +;;; replicate nil Cause arguments to be copied (preserving sharing in conses +;;; and arrays) before applying the operator. This is used to test +;;; destructive operators. +;;; +;;; + +(defun do-random-type-prop-tests + (operator arg-types minargs + &key + (maxargs minargs) + (rest-type t) + (reps *default-reps*) + (enclosing-the nil) + (arg-the *default-arg-the*) + (cell *default-cell*) + (ignore *default-ignore*) + (test #'regression-test::equalp-with-case) + (replicate nil replicate-p)) + (assert (<= 1 minargs maxargs 20)) +(prog1 + (dotimes (i reps) + again + (handler-bind + #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) + #+lispworks () + (let* ((param-names + '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 + p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) + (nargs (+ minargs (random (- maxargs minargs -1)))) + (types (subseq + (append arg-types + (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)))) + (vals + (if replicate + (mapcar #'replicate vals) + vals)) + (is-var? (if (consp replicate) + (progn + (assert (= (length replicate) (length vals))) + (loop for x in replicate collect (or x (coin)))) + (loop repeat (length vals) collect (coin)))) + (*is-var?* is-var?) + (params (loop for x in is-var? + for p in param-names + when x collect p)) + (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 + for tp in param-types + when x + collect `(type ,tp ,p))) + (rval (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (let* ((vals (if replicate (mapcar #'replicate vals) vals)) + (eval-form (cons operator (loop for v in vals + collect `(quote ,v))))) + ;; (print eval-form) (terpri) + ;; (dotimes (i 100) (eval eval-form)) + (eval eval-form)))) + (result-type (if (and enclosing-the (integerp rval)) + (make-random-type-containing rval) + 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 r))) + `(the ,tp ,p)) + p) + (if (or (consp v) + (and (symbolp v) (not (or (keywordp v) + (member v '(nil t)))))) + `(quote ,v) + v))))) + (speed (random 4)) + (space (random 4)) + (safety #-allegro (random 4) + #+allegro (1+ (random 3))) + (debug (random 4)) + (store-into-cell? (and cell (coin))) + (upgraded-result-type (and store-into-cell? + (upgraded-array-element-type `(eql ,rval)))) + (form + (setq *form* + `(lambda (,@(when store-into-cell? '(r)) ,@params) + (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) + ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) + ,@ type-decls) + ,(let ((result-form + (if enclosing-the `(the ,result-type ,expr) expr))) + (if store-into-cell? + `(setf (aref r) ,result-form) + result-form))))) + ) + (when *print-random-type-prop-input* + (let ((*print-pretty* t) + (*print-case* :downcase)) + (print (list :form form :vals vals)))) + (finish-output) + (let* ((param-vals (loop for x in is-var? + for v in vals + when x collect v)) + (fn (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (compile nil form))) + (result + (if store-into-cell? + (let ((r (make-array nil :element-type upgraded-result-type))) + (apply fn r param-vals) + (aref r)) + (apply fn param-vals)))) + (setq *random-type-prop-result* + (list :upgraded-result-type upgraded-result-type + :form form + :vals vals + :result result + :rval rval)) + (unless (funcall test result rval) + (return *random-type-prop-result*)))) + ;; #+allegro (excl::gc t) + )))) + +(defun make-random-arguments (types-or-funs) + (let ((vals nil)) + (loop for type-or-fun in types-or-funs + for type = (or (typecase type-or-fun + ((and function (not symbol)) + (apply type-or-fun vals)) + (t type-or-fun)) + (return-from make-random-arguments nil) ;; null type + ) + for val = (make-random-element-of-type type) + do (setf vals (nconc vals (list val)))) + ;; (dolist (v vals) (describe v)) + vals)) + +(defmacro defmethods (name &rest bodies) + `(progn + ,@(mapcar + #'(lambda (body) `(defmethod ,name ,@body)) + bodies))) + +(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 (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)))))) + + (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) + (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)) + (assert (< dim-index (array-rank array))) + (let ((dim (array-dimension array dim-index))) + (rcase (1 '*) (1 dim)))) + +;;; 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)) + ;; Add rule for creating new element types? + ))) + (rcase (1 alt-root) + (1 `(,alt-root)) + (1 `(,root ,etype)) + (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 ((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))))) + + (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 + +(defmacro def-type-prop-test (name &body args) + `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." + (string name)) + (find-package :cl-test)) + (do-random-type-prop-tests ,@args) + nil)) + +;;; Function used in constructing list types for some random type prop tests + +(defun make-list-type (length &optional (rest-type 'null) (element-type t)) + (let ((result rest-type)) + (loop repeat length + do (setq result `(cons ,element-type ,result))) + result)) + +(defun make-sequence-type (length &optional (element-type t)) + (rcase + (1 `(vector ,element-type ,length)) + (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))) + +(defun same-set-p (set1 set2 &rest args &key key test test-not) + (declare (ignorable key test test-not)) + (and (apply #'subsetp set1 set2 args) + (apply #'subsetp set2 set2 args) + t)) + +(defun index-type-for-dim (dim) + "Returns a function that computes integer type for valid indices + of an array dimension, or NIL if there are none." + #'(lambda (array &rest other) + (declare (ignore other)) + (let ((d (array-dimension array dim))) + (and (> d 0) `(integer 0 (,d)))))) + +(defun index-type-for-v1 (v1 &rest other) + "Computes integer type for valid indices for the first of two vectors" + (declare (ignore other)) + (let ((d (length v1))) `(integer 0 ,d))) + +(defun index-type-for-v2 (v1 v2 &rest other) + "Computes integer type for valid indices for the second of two vectors" + (declare (ignore v1 other)) + (let ((d (length v2))) `(integer 0 ,d))) + +(defun end-type-for-v1 (v1 v2 &rest other) + (declare (ignore v2)) + (let ((d (length v1)) + (start1 (or (cadr (member :start1 other)) 0))) + `(integer ,start1 ,d))) + +(defun end-type-for-v2 (v1 v2 &rest other) + (declare (ignore v1)) + (let ((d (length v2)) + (start2 (or (cadr (member :start2 other)) 0))) + `(integer ,start2 ,d))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)) + "Wrapper to create a hash table for structure sharing, if none exists." + (if (boundp '*replicate-table*) + (call-next-method obj) + (let ((*replicate-table* (make-hash-table))) + (call-next-method obj)))) + +(defmethod replicate ((obj cons)) + (or (gethash obj *replicate-table*) + (let ((x (cons nil nil))) + (setf (gethash obj *replicate-table*) x) + (setf (car x) (replicate (car obj))) + (setf (cdr x) (replicate (cdr obj))) + x))) + +;;; Default method for objects without internal structure +(defmethod replicate ((obj t)) obj) + +(defmethod replicate ((obj array)) + (multiple-value-bind + (new-obj old-leaf new-leaf) + (replicate-displaced-array obj) + (when new-leaf + (loop for i below (array-total-size new-leaf) + do (setf (row-major-aref new-leaf i) + (row-major-aref old-leaf i)))) + new-obj)) + +(defun replicate-displaced-array (obj) + "Replicate the non-terminal (and not already replicated) arrays + in a displaced array chain. Return the new root array, the + old leaf array, and the new (but empty) leaf array. The latter + two are NIL if the leaf did not have to be copied again." + (or (gethash obj *replicate-table*) + (multiple-value-bind + (displaced-to displaced-index-offset) + (array-displacement obj) + (let ((dims (array-dimensions obj)) + (element-type (array-element-type obj)) + (fill-pointer (and (array-has-fill-pointer-p obj) + (fill-pointer obj))) + (adj (adjustable-array-p obj))) + (if displaced-to + ;; The array is displaced + ;; Copy recursively + (multiple-value-bind + (new-displaced-to old-leaf new-leaf) + (replicate-displaced-array displaced-to) + (let ((new-obj (make-array dims :element-type element-type + :fill-pointer fill-pointer + :adjustable adj + :displaced-to new-displaced-to + :displaced-index-offset displaced-index-offset))) + (setf (gethash obj *replicate-table*) new-obj) + (values new-obj old-leaf new-leaf))) + ;; The array is not displaced + ;; This is the leaf array + (let ((new-obj (make-array dims :element-type element-type + :fill-pointer fill-pointer + :adjustable adj))) + (setf (gethash obj *replicate-table*) new-obj) + (values new-obj obj new-obj))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (special *isomorphism-table*)) + +(defun isomorphic-p (obj1 obj2) + (let ((*isomorphism-table* (make-hash-table))) + (isomorphic-p* obj1 obj2))) + +(defgeneric isomorphic-p* (obj1 obj2) + (:documentation + "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure, + including the same leaf values and the same pattern of sharing). It should be + the case that (isomorphic-p obj (replicate obj)) is true.")) + +(defmethod isomorphic-p* ((obj1 t) (obj2 t)) + (eql obj1 obj2)) + +(defmethod isomorphic-p* ((obj1 cons) (obj2 cons)) + (let ((previous (gethash obj1 *isomorphism-table*))) + (cond + (previous + ;; If we've already produced a mapping from obj1 to something, + ;; isomorphism requires that obj2 be that object + (eq previous obj2)) + ;; Otherwise, assume obj1 will map to obj2 and recurse + (t + (setf (gethash obj1 *isomorphism-table*) obj2) + (and (isomorphic-p* (car obj1) (car obj2)) + (isomorphic-p* (cdr obj1) (cdr obj2))))))) + +(defmethod isomorphic-p* ((obj1 array) (obj2 array)) + (let ((previous (gethash obj1 *isomorphism-table*))) + (cond + (previous + ;; If we've already produced a mapping from obj1 to something, + ;; isomorphism requires that obj2 be that object + (eq previous obj2)) + (t + (setf (gethash obj1 *isomorphism-table*) obj2) + (and (equal (array-dimensions obj1) (array-dimensions obj2)) + (equal (array-element-type obj1) (array-element-type obj2)) + (if (array-has-fill-pointer-p obj1) + (and (array-has-fill-pointer-p obj2) + (eql (fill-pointer obj1) (fill-pointer obj2))) + (not (array-has-fill-pointer-p obj2))) + (let (to-1 (index-1 0) to-2 (index-2 0)) + (multiple-value-setq (to-1 index-1) (array-displacement obj1)) + (multiple-value-setq (to-2 index-2) (array-displacement obj2)) + (if to-1 + (and to-2 + (eql index-1 index-2) + (isomorphic-p* to-1 to-2)) + ;; Not displaced -- recurse on elements + (let ((total-size (array-total-size obj1))) + (loop for i below total-size + 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))) diff --git a/random/random-types.lsp b/random/random-types.lsp new file mode 100644 index 0000000000000000000000000000000000000000..fa9b061d3ee3b0f5496b2e504d945321654ba60a --- /dev/null +++ b/random/random-types.lsp @@ -0,0 +1,369 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Oct 6 05:04:45 2003 +;;;; Contains: Generating random types and testing relationships on them + +(in-package :cl-test) + +(compile-and-load "types-aux.lsp") +(compile-and-load "random-aux.lsp") +(compile-and-load "random-int-form.lsp") + +(defparameter *random-types* nil) + +(defun make-random-type (size) + (if (<= size 1) + (rcase + (1 nil) + (1 t) + (1 `(eql ,(let ((r (ash 1 (random 45)))) + (random-from-interval r (- r))))) + (1 (random-from-seq #(integer unsigned-byte ratio rational real float + short-float single-float double-float + long-float complex symbol cons function))) + (1 + (let* ((len (random *maximum-random-int-bits*)) + (r1 (ash 1 len)) + (r2 (+ r1 r1)) + (x (- (random r2) r1)) + (y (- (random r2) r1)) + (lo (min x y)) + (hi (max x y))) + `(integer ,lo ,hi))) + (1 (make-random-real-type)) + ;; (1 (make-random-complex-type)) + ) + (rcase + (2 (let* ((op (random-from-seq #(cons cons and or))) + (nargs (if (eq op 'cons) 2 + (1+ (random (min size 4))))) + (sizes (random-partition (1- size) nargs))) + `(,op ,@(mapcar #'make-random-type sizes)))) + (1 `(not ,(make-random-type (1- size)))) + ; (1 (make-random-function-type size)) + ))) + +(defun make-random-real-type () + (rcase + (1 (random-from-seq '(integer unsigned-byte short-float single-float + double-float long-float rational real))) + (1 (destructuring-bind (lo hi) + (make-random-integer-range) + (rcase + (4 `(integer ,lo ,hi)) + (1 `(integer ,lo)) + (1 `(integer ,lo *)) + (2 `(integer * ,hi))))) + (1 (let ((r1 (random-real)) + (r2 (random-real))) + `(real ,(min r1 r2) ,(max r2 r2)))) + ;;; Add more cases here + )) + +(defun make-random-complex-type () + `(complex ,(make-random-real-type))) + +(defun make-random-function-type (size) + (let* ((sizes (random-partition (1- size) 2)) + (types (mapcar #'make-random-type sizes))) + `(function (,(car types)) ,(cadr types)))) + +(defun size-of-type (type) + (if (consp type) + (case (car type) + (complex (1+ (size-of-type (cadr type)))) + ((array simple-array) (1+ (size-of-type (cadr type)))) + (vector (1+ (size-of-type (cadr type)))) + (complex (1+ (size-of-type (cadr type)))) + ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 + :key #'size-of-type)) + (t 1)) + 1)) + +(defun mutate-type (type) + (let* ((size (size-of-type type)) + (r (random size))) + (flet ((%f () + (rcase + (6 (make-random-type (random (1+ size)))) + (2 `(not ,type)) + (1 `(and ,(make-random-type 1) ,type)) + (1 `(and ,type ,(make-random-type 1))) + (1 `(or ,(make-random-type 1) ,type)) + (1 `(or ,type ,(make-random-type 1))))) + (%random-int () + (let ((bits (1+ (min (random 20) (random 20))))) + (- (ash 1 bits) (random (ash 1 (1+ bits))))))) + (if (or (and (= r 0) (coin)) (not (consp type))) + (%f) + (case (car type) + ((and or not cons complex) + (let ((sizes (mapcar #'size-of-type (cdr type)))) + (loop with sum = 0 + for e on sizes + for ctype in (cdr type) + for i from 0 + do (setf sum (incf (car e) sum)) + when (>= sum r) + return (rcase + (1 ctype) ;; replace with component type + (1 (cons (car type) + (append (subseq (cdr type) 0 i) + (list (mutate-type ctype)) + (subseq (cdr type) (1+ i))))))))) + ((array simple-array vector) + (let ((ctype (if (cdr type) (cadr type) t))) + (rcase + (1 (if (eql ctype *) t ctype)) + (1 (cons (car type) + (cons (mutate-type ctype) + (cddr type))))))) + ((unsigned-byte) + (if (integerp (cadr type)) + (rcase + (1 'unsigned-byte) + (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) + (%f))) + + ((integer) + (let ((lo-delta (%random-int)) + (hi-delta (%random-int)) + (old-lo (or (cadr type) '*)) + (old-hi (or (caddr type) '*))) + (flet ((%inc (old delta) + (if (or (coin) (not (integerp old))) + delta + (+ old delta)))) + (rcase + (1 `(integer ,old-lo *)) + (1 `(integer * ,old-hi)) + (1 (let ((new-lo (%inc old-lo lo-delta))) + (if (or (null (cdr type)) + (null (cddr type)) + (not (integerp old-hi))) + `(integer ,new-lo ,@(cddr type)) + ;; caddr is integer + (if (<= new-lo old-hi) + `(integer ,new-lo ,old-hi) + `(integer ,old-hi ,new-lo))))) + (1 (let ((new-hi (%inc old-hi hi-delta))) + (if (or (null (cdr type)) + (null (cddr type)) + (not (integerp old-lo))) + `(integer ,old-lo ,new-hi) + (if (<= old-lo new-hi) + `(integer ,old-lo ,new-hi) + `(integer ,new-hi ,old-lo))))) + (1 (let ((new-lo (%inc old-lo lo-delta)) + (new-hi (%inc old-hi hi-delta))) + (if (<= new-lo new-hi) + `(integer ,new-lo ,new-hi) + `(integer ,new-hi ,new-lo)))))))) + + (t (%f))))))) + +(defun test-random-types (n size) + (loop for t1 = (make-random-type size) + for t2 = (make-random-type size) + for i from 0 below n + ;; do (print (list t1 t2)) + do (setf *random-types* (list t1 t2)) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-types t1 t2) + collect (list t1 t2) + finally (terpri))) + +(defun test-random-mutated-types (n size &key (reps 1)) + (loop for t1 = (make-random-type size) + 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)) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-types t1 t2) + collect (list t1 t2) + finally (terpri))) + +(defun test-types (t1 t2) + (multiple-value-bind (sub success) + (subtypep t1 t2) + (when success + (if sub + (check-all-subtypep t1 t2) + (let ((nt1 `(not ,t1)) + (nt2 `(not ,t2))) + (subtypep nt2 nt1)))))) + +(defun prune-type (tp try-fn) + (declare (type function try-fn)) + (flet ((try (x) (funcall try-fn x))) + (cond + ((member tp '(nil t))) + ((symbolp tp) + (try nil) + (try t)) + ((consp tp) + (try nil) + (try t) + (let ((op (first tp)) + (args (rest tp))) + (case op + ((cons) + (try 'cons) + (prune-list args + #'prune-type + #'(lambda (args) (try `(cons ,@args))))) + ((integer) + (try op) + (try '(eql 0)) + (when (= (length args) 2) + (let ((arg1 (first args)) + (arg2 (second args))) + (when (and (integerp arg1) (integerp arg2)) + (try `(eql ,arg1)) + (try `(eql ,arg2)) + (when (and (< arg1 0) (<= 0 arg2)) + (try `(integer 0 ,arg2))) + (when (and (<= arg1 0) (< 0 arg2)) + (try `(integer ,arg1 0))) + (when (> (- arg2 arg1) 1) + (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) + (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) + + ((real float ratio single-float double-float short-float long-float) + (try op)) + + ((or and) + (mapc try-fn args) + (loop for i from 0 below (length args) + do (try `(,op ,@(subseq args 0 i) + ,@(subseq args (1+ i))))) + (prune-list args + #'prune-type + #'(lambda (args) (try (cons op args))))) + ((not) + (let ((arg (first args))) + (try arg) + (when (and (consp arg) + (eq (car arg) 'not)) + (try (second arg))) + (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) + + ((member) + (dolist (arg (cdr tp)) + (try `(eql ,arg))) + (when (cddr tp) + (try `(member ,@(cddr tp))))) + + ((eql) + (assert (= (length args) 1)) + (let ((arg (first args))) + (unless (= arg 0) + (try `(eql 0)) + (cond + ((< arg -1) + (try `(eql ,(ceiling arg 2)))) + ((> arg 1) + (try `(eql ,(floor arg 2)))))))) + + ))))) + (values)) + +(defun prune-type-pair (pair &optional (fn #'test-types)) + (declare (type function fn)) + (let ((t1 (first pair)) + (t2 (second pair)) + changed) + (loop + do (flet ((%try2 (new-tp) + (when (funcall fn t1 new-tp) + (print "Success in first loop") + (print new-tp) + (setq t2 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t2 #'%try2))) + do (flet ((%try1 (new-tp) + (when (funcall fn new-tp t2) + (print "Success in second loop") + (print new-tp) + (setq t1 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t1 #'%try1))) + while changed + do (setq changed nil)) + (list t1 t2))) + +(defun test-type-triple (t1 t2 t3) + ;; Returns non-nil if a problem is found + (catch 'problem + (multiple-value-bind (sub1 success1) + (subtypep t1 t2) + (when success1 + (if sub1 + (append + (check-all-subtypep t1 `(or ,t2 ,t3)) + (check-all-subtypep `(and ,t1 ,t3) t2)) + (or (subtypep `(or ,t1 ,t3) t2) + (subtypep t1 `(and ,t2 ,t3)))))))) + +(defun test-random-types3 (n size) + (loop for t1 = (make-random-type (1+ (random size))) + for t2 = (make-random-type (1+ (random size))) + for t3 = (make-random-type (1+ (random size))) + for i from 1 to n + ;; do (print (list t1 t2)) + do (setf *random-types* (list t1 t2 t3)) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-type-triple t1 t2 t3) + collect (list t1 t2 t3) + finally (terpri))) + +(defun prune-type-triple (pair &optional (fn #'test-type-triple)) + (declare (type function fn)) + (let ((t1 (first pair)) + (t2 (second pair)) + (t3 (third pair)) + changed) + (loop + do (flet ((%try2 (new-tp) + (when (funcall fn t1 new-tp t3) + (print "Success in first loop") + (print new-tp) + (setq t2 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t2 #'%try2))) + do (flet ((%try1 (new-tp) + (when (funcall fn new-tp t2 t3) + (print "Success in second loop") + (print new-tp) + (setq t1 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t1 #'%try1))) + do (flet ((%try3 (new-tp) + (when (funcall fn t1 t2 new-tp) + (print "Success in second loop") + (print new-tp) + (setq t3 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t3 #'%try3))) + while changed + do (setq changed nil)) + (list t1 t2 t3))) + + + +