diff --git a/array.lsp b/arrays/array.lsp similarity index 100% rename from array.lsp rename to arrays/array.lsp diff --git a/ansi-aux-macros.lsp b/auxiliary/ansi-aux-macros.lsp similarity index 100% rename from ansi-aux-macros.lsp rename to auxiliary/ansi-aux-macros.lsp diff --git a/ansi-aux.lsp b/auxiliary/ansi-aux.lsp similarity index 100% rename from ansi-aux.lsp rename to auxiliary/ansi-aux.lsp diff --git a/array-aux.lsp b/auxiliary/array-aux.lsp similarity index 100% rename from array-aux.lsp rename to auxiliary/array-aux.lsp diff --git a/backquote-aux.lsp b/auxiliary/backquote-aux.lsp similarity index 100% rename from backquote-aux.lsp rename to auxiliary/backquote-aux.lsp diff --git a/bit-aux.lsp b/auxiliary/bit-aux.lsp similarity index 100% rename from bit-aux.lsp rename to auxiliary/bit-aux.lsp diff --git a/ceiling-aux.lsp b/auxiliary/ceiling-aux.lsp similarity index 100% rename from ceiling-aux.lsp rename to auxiliary/ceiling-aux.lsp diff --git a/char-aux.lsp b/auxiliary/char-aux.lsp similarity index 100% rename from char-aux.lsp rename to auxiliary/char-aux.lsp diff --git a/cl-symbols-aux.lsp b/auxiliary/cl-symbols-aux.lsp similarity index 100% rename from cl-symbols-aux.lsp rename to auxiliary/cl-symbols-aux.lsp diff --git a/cons-aux.lsp b/auxiliary/cons-aux.lsp similarity index 100% rename from cons-aux.lsp rename to auxiliary/cons-aux.lsp diff --git a/defclass-aux.lsp b/auxiliary/defclass-aux.lsp similarity index 100% rename from defclass-aux.lsp rename to auxiliary/defclass-aux.lsp diff --git a/define-condition-aux.lsp b/auxiliary/define-condition-aux.lsp similarity index 100% rename from define-condition-aux.lsp rename to auxiliary/define-condition-aux.lsp diff --git a/division-aux.lsp b/auxiliary/division-aux.lsp similarity index 100% rename from division-aux.lsp rename to auxiliary/division-aux.lsp diff --git a/exp-aux.lsp b/auxiliary/exp-aux.lsp similarity index 100% rename from exp-aux.lsp rename to auxiliary/exp-aux.lsp diff --git a/fceiling-aux.lsp b/auxiliary/fceiling-aux.lsp similarity index 100% rename from fceiling-aux.lsp rename to auxiliary/fceiling-aux.lsp diff --git a/ffloor-aux.lsp b/auxiliary/ffloor-aux.lsp similarity index 100% rename from ffloor-aux.lsp rename to auxiliary/ffloor-aux.lsp diff --git a/floor-aux.lsp b/auxiliary/floor-aux.lsp similarity index 100% rename from floor-aux.lsp rename to auxiliary/floor-aux.lsp diff --git a/fround-aux.lsp b/auxiliary/fround-aux.lsp similarity index 100% rename from fround-aux.lsp rename to auxiliary/fround-aux.lsp diff --git a/ftruncate-aux.lsp b/auxiliary/ftruncate-aux.lsp similarity index 100% rename from ftruncate-aux.lsp rename to auxiliary/ftruncate-aux.lsp diff --git a/gcd-aux.lsp b/auxiliary/gcd-aux.lsp similarity index 100% rename from gcd-aux.lsp rename to auxiliary/gcd-aux.lsp diff --git a/hash-table-aux.lsp b/auxiliary/hash-table-aux.lsp similarity index 100% rename from hash-table-aux.lsp rename to auxiliary/hash-table-aux.lsp diff --git a/numbers-aux.lsp b/auxiliary/numbers-aux.lsp similarity index 100% rename from numbers-aux.lsp rename to auxiliary/numbers-aux.lsp diff --git a/package-aux.lsp b/auxiliary/package-aux.lsp similarity index 100% rename from package-aux.lsp rename to auxiliary/package-aux.lsp diff --git a/pathnames-aux.lsp b/auxiliary/pathnames-aux.lsp similarity index 100% rename from pathnames-aux.lsp rename to auxiliary/pathnames-aux.lsp diff --git a/printer-aux.lsp b/auxiliary/printer-aux.lsp similarity index 100% rename from printer-aux.lsp rename to auxiliary/printer-aux.lsp diff --git a/random-aux.lsp b/auxiliary/random-aux.lsp similarity index 100% rename from random-aux.lsp rename to auxiliary/random-aux.lsp diff --git a/random-class-aux.lsp b/auxiliary/random-class-aux.lsp similarity index 100% rename from random-class-aux.lsp rename to auxiliary/random-class-aux.lsp diff --git a/reader-aux.lsp b/auxiliary/reader-aux.lsp similarity index 100% rename from reader-aux.lsp rename to auxiliary/reader-aux.lsp diff --git a/remove-aux.lsp b/auxiliary/remove-aux.lsp similarity index 100% rename from remove-aux.lsp rename to auxiliary/remove-aux.lsp diff --git a/remove-duplicates-aux.lsp b/auxiliary/remove-duplicates-aux.lsp similarity index 100% rename from remove-duplicates-aux.lsp rename to auxiliary/remove-duplicates-aux.lsp diff --git a/round-aux.lsp b/auxiliary/round-aux.lsp similarity index 100% rename from round-aux.lsp rename to auxiliary/round-aux.lsp diff --git a/search-aux.lsp b/auxiliary/search-aux.lsp similarity index 100% rename from search-aux.lsp rename to auxiliary/search-aux.lsp diff --git a/sort-aux.lsp b/auxiliary/sort-aux.lsp similarity index 100% rename from sort-aux.lsp rename to auxiliary/sort-aux.lsp diff --git a/string-aux.lsp b/auxiliary/string-aux.lsp similarity index 100% rename from string-aux.lsp rename to auxiliary/string-aux.lsp diff --git a/subseq-aux.lsp b/auxiliary/subseq-aux.lsp similarity index 100% rename from subseq-aux.lsp rename to auxiliary/subseq-aux.lsp diff --git a/times-aux.lsp b/auxiliary/times-aux.lsp similarity index 100% rename from times-aux.lsp rename to auxiliary/times-aux.lsp diff --git a/truncate-aux.lsp b/auxiliary/truncate-aux.lsp similarity index 100% rename from truncate-aux.lsp rename to auxiliary/truncate-aux.lsp diff --git a/types-aux.lsp b/auxiliary/types-aux.lsp similarity index 100% rename from types-aux.lsp rename to auxiliary/types-aux.lsp diff --git a/make-random-element-of.lsp b/make-random-element-of.lsp deleted file mode 100644 index dcbea8a92ca70f2668e6fd51c6c8b25ebf1cdb05..0000000000000000000000000000000000000000 --- a/make-random-element-of.lsp +++ /dev/null @@ -1,274 +0,0 @@ -;-*- 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-class.lsp b/random-class.lsp deleted file mode 100644 index 1453fdd222d03c80d8559212fbc90d643cb74143..0000000000000000000000000000000000000000 --- a/random-class.lsp +++ /dev/null @@ -1,9 +0,0 @@ -;-*- 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-int-form.lsp b/random-int-form.lsp deleted file mode 100644 index 7c18b164891ab851edb6135051f5f5e95d4e584d..0000000000000000000000000000000000000000 --- a/random-int-form.lsp +++ /dev/null @@ -1,2971 +0,0 @@ -;-*- 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-intern.lsp b/random-intern.lsp deleted file mode 100644 index 5041b984197cb1b1b35bf8156def59a176fcce88..0000000000000000000000000000000000000000 --- a/random-intern.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- 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-type-prop-tests-01.lsp b/random-type-prop-tests-01.lsp deleted file mode 100644 index da3a53e44b7e80b2957c6e032fa9886dd224b29a..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-01.lsp +++ /dev/null @@ -1,73 +0,0 @@ -;-*- 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-type-prop-tests-02.lsp b/random-type-prop-tests-02.lsp deleted file mode 100644 index 458aa8fcd5acbc35556386a6f4d07a6c9c42f8d5..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-02.lsp +++ /dev/null @@ -1,115 +0,0 @@ -;-*- 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-type-prop-tests-03.lsp b/random-type-prop-tests-03.lsp deleted file mode 100644 index a564c2149995b22582a99d8466e46819fe08ad2a..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-03.lsp +++ /dev/null @@ -1,186 +0,0 @@ -;-*- 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-type-prop-tests-04.lsp b/random-type-prop-tests-04.lsp deleted file mode 100644 index b12aae407e0e8b6810d371e297df427da2e6060e..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-04.lsp +++ /dev/null @@ -1,107 +0,0 @@ -;-*- 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-type-prop-tests-05.lsp b/random-type-prop-tests-05.lsp deleted file mode 100644 index 5ef8ee93554a63e4e82e918e8b472f245b188f3c..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-05.lsp +++ /dev/null @@ -1,528 +0,0 @@ -;-*- 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-type-prop-tests-06.lsp b/random-type-prop-tests-06.lsp deleted file mode 100644 index b90f9d05fc4b831e9eafd114e32049fc5b079f3f..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-06.lsp +++ /dev/null @@ -1,146 +0,0 @@ -;-*- 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-type-prop-tests-07.lsp b/random-type-prop-tests-07.lsp deleted file mode 100644 index efe6f59b1e92cf91e2f91d854e8f0a436e6e9756..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-07.lsp +++ /dev/null @@ -1,121 +0,0 @@ -;-*- 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-type-prop-tests-08.lsp b/random-type-prop-tests-08.lsp deleted file mode 100644 index 9f8c938cd7fbc40bc17f6bb70515fa3d973e6bdc..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-08.lsp +++ /dev/null @@ -1,348 +0,0 @@ -;-*- 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-type-prop-tests-09.lsp b/random-type-prop-tests-09.lsp deleted file mode 100644 index 46270c318e133c091ca73a0ece40c94eebb6df36..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-09.lsp +++ /dev/null @@ -1,717 +0,0 @@ -;-*- 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-type-prop-tests-10.lsp b/random-type-prop-tests-10.lsp deleted file mode 100644 index 71d23474ad7e02084b378c457ac2b8eb904b7f5e..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-10.lsp +++ /dev/null @@ -1,114 +0,0 @@ -;-*- 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-type-prop-tests-structs.lsp b/random-type-prop-tests-structs.lsp deleted file mode 100644 index 9a4423ad968c6274baff3fb505d98f4a87c9a611..0000000000000000000000000000000000000000 --- a/random-type-prop-tests-structs.lsp +++ /dev/null @@ -1,72 +0,0 @@ -;-*- 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-type-prop-tests.lsp b/random-type-prop-tests.lsp deleted file mode 100644 index 6f86d1c75ed07c5fefb033221637f4ee79255678..0000000000000000000000000000000000000000 --- a/random-type-prop-tests.lsp +++ /dev/null @@ -1,22 +0,0 @@ -;-*- 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-type-prop.lsp b/random-type-prop.lsp deleted file mode 100644 index bacb02cf00065a4de6a01f621aa58c95202191ec..0000000000000000000000000000000000000000 --- a/random-type-prop.lsp +++ /dev/null @@ -1,664 +0,0 @@ -;-*- 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-types.lsp b/random-types.lsp deleted file mode 100644 index fa9b061d3ee3b0f5496b2e504d945321654ba60a..0000000000000000000000000000000000000000 --- a/random-types.lsp +++ /dev/null @@ -1,369 +0,0 @@ -;-*- 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))) - - - -