From efdc9154ca3f5be5bf769459dbc5fe8b48da81ca Mon Sep 17 00:00:00 2001 From: Karsten Poeck <karsten.poeck@gmail.com> Date: Sat, 28 May 2022 19:28:53 +0200 Subject: [PATCH] Merged with pfdietz version --- README | 6 +- auxiliary/ansi-aux-macros.lsp | 2 +- auxiliary/ansi-aux.lsp | 13 +- auxiliary/random-aux.lsp | 38 +- auxiliary/types-aux.lsp | 40 +- cl-test-package.lsp | 1 + clasp/ansi-setup-clasp.lisp | 1 + conditions/define-condition.lsp | 1 + cons/assoc.lsp | 15 + data-and-control-flow/equal.lsp | 42 + data-and-control-flow/flet.lsp | 1 + data-and-control-flow/labels.lsp | 1 + data-and-control-flow/macrolet.lsp | 1 + doit-clasp-random-tester.lsp | 5 - eval-and-compile/declaration.lsp | 4 +- printer/format/format-logical-block.lsp | 11 + printer/format/format-t.lsp | 14 + random/random-int-form.lsp | 1514 ++++++++++++++++++--- random/random-type-prop-tests-01.lsp | 107 +- random/random-type-prop-tests-02.lsp | 36 + random/random-type-prop-tests-03.lsp | 138 +- random/random-type-prop-tests-04.lsp | 2 +- random/random-type-prop-tests-05.lsp | 7 +- random/random-type-prop-tests-07.lsp | 4 + random/random-type-prop-tests-08.lsp | 106 +- random/random-type-prop-tests-09.lsp | 16 + random/random-type-prop-tests-10.lsp | 73 + random/random-type-prop-tests-structs.lsp | 14 + random/random-type-prop-tests.lsp | 14 +- random/random-type-prop.lsp | 266 +++- random/random-types.lsp | 117 +- structures/structure-00.lsp | 5 + system-construction/compile-file.lsp | 1 + universe.lsp | 8 +- 34 files changed, 2273 insertions(+), 351 deletions(-) diff --git a/README b/README index f0de4a02..95a7268b 100644 --- a/README +++ b/README @@ -19,7 +19,7 @@ LISP to the lisp executable to be tested, then invoking Please tell me when you find incorrect test cases. Paul Dietz - dietz@dls.net + paul.f.dietz@gmail.com -------------------------------- @@ -36,6 +36,10 @@ please contact me and I will add code to do so. -------------------------------- +To run random tests, see random/README. + +-------------------------------- + NOTE!!! This test suite is not intended to rank Common Lisp implementations. diff --git a/auxiliary/ansi-aux-macros.lsp b/auxiliary/ansi-aux-macros.lsp index 6b4b9030..1b49e87f 100644 --- a/auxiliary/ansi-aux-macros.lsp +++ b/auxiliary/ansi-aux-macros.lsp @@ -3,7 +3,7 @@ ;;;; Created: Wed Jul 2 07:05:41 2003 ;;;; Contains: Macros used in ansi-aux and elsewhere. - +(in-package :cl-test) (declaim (optimize (safety 3))) diff --git a/auxiliary/ansi-aux.lsp b/auxiliary/ansi-aux.lsp index 6deac06f..89daeec3 100644 --- a/auxiliary/ansi-aux.lsp +++ b/auxiliary/ansi-aux.lsp @@ -3,7 +3,7 @@ ;;;; Created: Sat Mar 28 17:10:18 1998 ;;;; Contains: Aux. functions for CL-TEST - +(in-package :cl-test) (declaim (optimize (safety 3))) @@ -1188,3 +1188,14 @@ the condition to go uncaught if it cannot be classified." (defmacro expand-in-current-env (macro-form &environment env) (macroexpand macro-form env)) + +;;; LOAD does not necessarily behave correctly in some lisps. +;;; Manually merge *default-pathname-defaults* + +(defun load-merge (pathspec) + (load (merge-pathnames (pathname pathspec) *default-pathname-defaults*))) + +(defun load-here (pathspec) + (let ((*default-pathname-defaults* + (make-pathname :directory (pathname-directory *load-pathname*)))) + (load-merge pathspec))) diff --git a/auxiliary/random-aux.lsp b/auxiliary/random-aux.lsp index b86fbbcb..c30f519d 100644 --- a/auxiliary/random-aux.lsp +++ b/auxiliary/random-aux.lsp @@ -7,8 +7,12 @@ (declaim (special +standard-chars+ *cl-symbols-vector*)) +(defun coin (&optional (n 2)) + "Flip an n-sided coin." + (eql (random n) 0)) + (defvar *maximum-random-int-bits* - (max 36 (1+ (integer-length most-positive-fixnum)))) + (max 36 (+ 4 (integer-length most-positive-fixnum)))) (defun random-from-seq (seq) "Generate a random member of a sequence." @@ -163,15 +167,6 @@ (+ (random (1+ (- most-positive-fixnum most-negative-fixnum))) most-negative-fixnum)) -(defun random-thing (n) - (if (<= n 1) - (random-leaf) - (rcase - (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) - (1 (apply #'vector (mapcar #'random-thing - (random-partition (1- n) (max 10 (1- n)))))) - ))) - (defparameter *use-random-byte* t) (defparameter *random-readable* nil) @@ -219,6 +214,9 @@ s)) +(defun random-from-interval (upper &optional (lower (- upper))) + (+ (random (- upper lower)) lower)) + (defun random-leaf () (rcase (1 (let ((k (ash 1 (1+ (random 40))))) @@ -230,13 +228,6 @@ (1 (make-symbol (make-random-string (random 20)))) (1 (random-from-seq *cl-symbols-vector*)))) -(defun random-from-interval (upper &optional (lower (- upper))) - (+ (random (- upper lower)) lower)) - -(defun coin (&optional (n 2)) - "Flip an n-sided coin." - (eql (random n) 0)) - ;;; Randomly permute a sequence (defun random-permute (seq) (setq seq (copy-seq seq)) @@ -303,3 +294,16 @@ method-list))) `(loop (catch 'fail (return (rcase ,@clauses)))))) +(defun init-random-state () + "Initialize random state to some arbitrary nondeterministic value, to make fresh runs of random testing different" + (setf *random-state* (make-random-state t)) + (values)) + +(defun random-thing (n) + (if (<= n 1) + (random-leaf) + (rcase + (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) + (1 (apply #'vector (mapcar #'random-thing + (random-partition (1- n) (max 10 (1- n)))))) + ))) diff --git a/auxiliary/types-aux.lsp b/auxiliary/types-aux.lsp index 091af89e..4a389d50 100644 --- a/auxiliary/types-aux.lsp +++ b/auxiliary/types-aux.lsp @@ -3,16 +3,22 @@ ;;;; Created: Mon Jun 21 20:14:38 2004 ;;;; Contains: Aux. functions for types tests -(defun classes-are-disjoint (c1 c2) - "If either c1 or c2 is a builtin class or the name of a builtin - class, then check for disjointness. Return a non-NIL list - of failed subtypep relationships, if any." - (and (or (is-builtin-class c1) - (is-builtin-class c2)) - (check-disjointness c1 c2))) +(in-package :cl-test) (declaim (special *subtype-table*)) +(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) + (multiple-value-bind + (sub valid) + (subtypep type1 type2) + (unless (constantp type1) (setq type1 (list 'quote type1))) + (unless (constantp type2) (setq type2 (list 'quote type2))) + (if (or (and valid sub (not is-sub)) + (and valid (not sub) is-sub) + (and (not valid) should-be-valid)) + `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) + nil))) + (defun types.6-body () (loop for p in *subtype-table* @@ -106,18 +112,6 @@ (condition (c) (format t "Error ~S occured: ~S~%" c tp) 1)))))))) -(defun check-subtypep (type1 type2 is-sub &optional should-be-valid) - (multiple-value-bind - (sub valid) - (subtypep type1 type2) - (unless (constantp type1) (setq type1 (list 'quote type1))) - (unless (constantp type2) (setq type2 (list 'quote type2))) - (if (or (and valid sub (not is-sub)) - (and valid (not sub) is-sub) - (and (not valid) should-be-valid)) - `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) - nil))) - ;;; Check that the subtype relationships implied ;;; by disjointness are not contradicted. Return NIL ;;; if ok, or a list of error messages if not. @@ -184,3 +178,11 @@ (deftype even-array (&optional type size) `(and (array ,type ,size) (satisfies even-size-p))) + +(defun classes-are-disjoint (c1 c2) + "If either c1 or c2 is a builtin class or the name of a builtin + class, then check for disjointness. Return a non-NIL list + of failed subtypep relationships, if any." + (and (or (is-builtin-class c1) + (is-builtin-class c2)) + (check-disjointness c1 c2))) diff --git a/cl-test-package.lsp b/cl-test-package.lsp index 7f2b7406..c0701603 100644 --- a/cl-test-package.lsp +++ b/cl-test-package.lsp @@ -7,6 +7,7 @@ (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test)))) (let ((*package* pkg)) + ;; These are shadowed to avoid annoying SBCL notes (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load common-lisp-user::compile-and-load*) diff --git a/clasp/ansi-setup-clasp.lisp b/clasp/ansi-setup-clasp.lisp index c7acc5bf..ae34fe75 100644 --- a/clasp/ansi-setup-clasp.lisp +++ b/clasp/ansi-setup-clasp.lisp @@ -17,6 +17,7 @@ (rt:disable-note :nil-vectors-are-strings) (rt:disable-note :allow-nil-arrays) (rt:disable-note :make-condition-with-compound-name) + (rt:disable-note :no-floating-point-underflow-by-default) #+(or)(rt:rem-test 'cl-test::sublis.error.8) #+(or)(rt:rem-test 'cl-test::nsublis.error.8) #+(or)(rt:rem-test 'cl-test::get-properties.error.4) diff --git a/conditions/define-condition.lsp b/conditions/define-condition.lsp index ae02b60c..54ec9d69 100644 --- a/conditions/define-condition.lsp +++ b/conditions/define-condition.lsp @@ -288,6 +288,7 @@ (with-output-to-string (s) (print-object c s))) "The report for condition-16") +(declaim (ftype (function (t) *) condition-17/s)) (defun condition-17-report (c s) (format s "condition-17: ~A" (condition-17/s c))) diff --git a/cons/assoc.lsp b/cons/assoc.lsp index bbe38bb3..e76f955e 100644 --- a/cons/assoc.lsp +++ b/cons/assoc.lsp @@ -163,6 +163,21 @@ :test #'eq)) (nil . e)) + +;;; No match, but with key, test, test-not + +(deftest assoc.32 + (assoc 1 (list (cons 1 2)) :key #'1+) + nil) + +(deftest assoc.33 + (assoc 1 (list (cons 1 2)) :test #'/=) + nil) + +(deftest assoc.34 + (assoc 1 (list (cons 1 2)) :test-not #'=) + nil) + ;;; :test & :test-not together are harmless (defharmless assoc.test-and-test-not.1 diff --git a/data-and-control-flow/equal.lsp b/data-and-control-flow/equal.lsp index 17260f76..40263033 100644 --- a/data-and-control-flow/equal.lsp +++ b/data-and-control-flow/equal.lsp @@ -113,6 +113,48 @@ (values (equalt s "012") (equalt "012" s))) t t) +(deftest equal.20 + (let ((fn '(lambda (x y) + (declare + (type (simple-array bit (*)) x) + (type (and (array bit (*)) (not simple-array)) y)) + (equal x y))) + (v1 (coerce #*10110 'simple-bit-vector)) + (v2 (make-array '(5) :element-type 'bit + :initial-contents '(1 0 1 1 0) + :adjustable t))) + (values (not (not (equal v1 v2))) + (funcall (compile nil fn) v1 v2))) + t t) + +(deftest equal.21 + (let ((fn '(lambda (x y) + (declare + (type (simple-array base-char (*)) x) + (type (simple-array character (*)) y)) + (equal x y))) + (v1 (coerce "acndaa" 'simple-base-string)) + (v2 (make-array '(6) :element-type 'character + :initial-contents '(#\a #\c #\n #\d #\a #\a)))) + (let ((cfn (compile nil fn))) + (values (not (not (equal v1 v2))) + (funcall cfn v1 v2)))) + t t) + +(deftest equal.22 + (let ((fn '(lambda (x y) + (declare + (type (simple-array base-char (*)) x) + (type (and base-string (not simple-array)) y)) + (equal x y))) + (v1 (coerce "acndaa" 'simple-base-string)) + (v2 (make-array '(6) :element-type 'base-char + :adjustable t + :initial-contents '(#\a #\c #\n #\d #\a #\a)))) + (values (not (not (equal v1 v2))) + (funcall (compile nil fn) v1 v2))) + t t) + ;;; Should add more pathname equality tests (deftest equal.order.1 diff --git a/data-and-control-flow/flet.lsp b/data-and-control-flow/flet.lsp index f4e09120..9de0fb1e 100644 --- a/data-and-control-flow/flet.lsp +++ b/data-and-control-flow/flet.lsp @@ -577,6 +577,7 @@ :good) (define-compiler-macro flet.74 (&whole form) + (declare (ignorable form)) :bad) (deftest flet.74 diff --git a/data-and-control-flow/labels.lsp b/data-and-control-flow/labels.lsp index 47ee6c9d..22d7e4f7 100644 --- a/data-and-control-flow/labels.lsp +++ b/data-and-control-flow/labels.lsp @@ -427,6 +427,7 @@ :good) (define-compiler-macro labels.52 (&whole form) + (declare (ignorable form)) :bad) (deftest labels.52 diff --git a/data-and-control-flow/macrolet.lsp b/data-and-control-flow/macrolet.lsp index 3cb5d199..ceb87928 100644 --- a/data-and-control-flow/macrolet.lsp +++ b/data-and-control-flow/macrolet.lsp @@ -464,6 +464,7 @@ :good) (define-compiler-macro macrolet.52 (&whole form) + (declare (ignorable form)) :bad) (deftest macrolet.52 diff --git a/doit-clasp-random-tester.lsp b/doit-clasp-random-tester.lsp index 01dc87e6..121458bb 100644 --- a/doit-clasp-random-tester.lsp +++ b/doit-clasp-random-tester.lsp @@ -36,11 +36,6 @@ (handler-bind ((style-warning #'muffle-warning)) (test-random-integer-forms 100 4 200)))) -#| -(load "~/fork-ansi-test/doit-clasp-random-tester.lsp" :print t) -(load "~/pfdietz-ansi-test/doit-clasp-random-tester.lsp" :print t) -|# - diff --git a/eval-and-compile/declaration.lsp b/eval-and-compile/declaration.lsp index f216e187..22f80108 100644 --- a/eval-and-compile/declaration.lsp +++ b/eval-and-compile/declaration.lsp @@ -30,7 +30,9 @@ ;;; Declare these only if bad declarations produce warnings. (when (block done - (handler-bind ((warning #'(lambda (c) (return-from done t)))) + (handler-bind ((warning #'(lambda (c) + (declare (ignore c)) + (return-from done t)))) (eval `(let () (declare (,(gensym))) nil)))) (deftest declaration.4 diff --git a/printer/format/format-logical-block.lsp b/printer/format/format-logical-block.lsp index 7a55daa1..98155f11 100644 --- a/printer/format/format-logical-block.lsp +++ b/printer/format/format-logical-block.lsp @@ -111,6 +111,17 @@ (signals-error-always (format nil "1~<X~<Y~:>Z~>2" nil nil nil) error) t t) +;;; "an error is also signaled if the ~<...~:;...~> form of ~<...~> is used +;;; in the same format string with ~W, ~_, ~<...~:>, ~I, or ~:T." + +(deftest format.logical-block.error.26 + (signals-error-always (format nil "~<~:;~>~<~:>" nil nil nil) error) + t t) + +(deftest format.logical-block.error.27 + (signals-error-always (format nil "~<~:>~<~:;~>" nil nil nil) error) + t t) + ;;; Non-error tests (def-pprint-test format.logical-block.1 diff --git a/printer/format/format-t.lsp b/printer/format/format-t.lsp index 3acdbd50..d1ceb4d4 100644 --- a/printer/format/format-t.lsp +++ b/printer/format/format-t.lsp @@ -261,6 +261,20 @@ collect (list n1 n2 inc s2 result)) nil) +;;; see 22.3.5.2 + +(deftest format.\:t.error.1 + (signals-error-always (format nil "~<XXX~1,1:TYYY~>") error) + t t) + +(deftest format.\:t.error.2 + (signals-error-always (format nil "~<XXX~:;YYY~>ZZZ~4,5:tWWW") error) + t t) + +(deftest format.\:t.error.3 + (signals-error-always (format nil "AAAA~1,1:TBBB~<XXX~:;YYY~>ZZZ") error) + t t) + ;;; ~:@t (def-pprint-test format.\:@t.1 diff --git a/random/random-int-form.lsp b/random/random-int-form.lsp index ea599ff7..33764cfa 100644 --- a/random/random-int-form.lsp +++ b/random/random-int-form.lsp @@ -5,7 +5,7 @@ (in-package :cl-test) -(compile-and-load* "random-aux.lsp") +;; (compile-and-load* "random-aux.lsp") ;;; ;;; This file contains a routine for generating random legal Common Lisp functions @@ -42,21 +42,189 @@ (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* *opt-result* *unopt-result* $x $y $z - *compile-unoptimized-form* + *compile-unoptimized-form* *require-type-passed* + *default-make-random-integer-form-cdf* *make-random-integer-form-cdf*)) +(defvar *mutex* #+sbcl (sb-thread:make-mutex) #-sbcl nil + "In SBCL, the mutex used to control output from loop-random-int-forms") + +(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 *innocuous-failures* nil) + +(defvar *compile-unoptimized-form* + #+(or allegro sbcl) t + #-(or allegro sbcl) nil) + +(declaim (special *vars*)) + +(defparameter *random-int-form-progress-output* t + "When true, random int form testing prints progress output") + +(defparameter *fn-state* 0 + "An integer variable that is used as state of a function in generated forms") + +(defun fn-with-state (x) + (incf *fn-state* (logand #xffff x))) + +(declaim (notinline fn-with-state)) + +(defparameter *previous-constants* nil + "A list of constants previously generated in generating these forms") + +(defgeneric make-random-element-of-type (type) + (:documentation "Create a random element of a lisp type.")) + +;; Structure type(s) used in tests + +(defparameter *int-structs* nil + "List of descriptors (name constructor (initarg accessor type)*) for the +structures used in random tests.") + +(defmacro def-int-struct (tag type &optional (initform 0)) + (let* ((name (intern (format nil "RIF-STRUCT-~A" tag) :cl-test)) + (accessor (intern (format nil "~A-N" name) :cl-test)) + (constructor (intern (format nil "MAKE-~A" name) :cl-test))) + `(progn + (eval-when (:load-toplevel) + (setf (get ',name 'is-int-struct-type) t) + (setf (get ',name 'int-struct-accessor) ',accessor) + (setf (get ',constructor 'int-struct-constructor-of) ',name) + (pushnew '(,name ,constructor (:n ,accessor ,type)) *int-structs* :test #'equal)) + (defstruct ,name + (n ,initform :type ,type)) + (defmethod make-random-element-of-type ((type (eql ',name))) + (,constructor :n (make-random-element-of-type ',type))) + ))) + +(defmethod is-int-struct-type? ((sym symbol)) + (get sym 'is-int-struct-type)) + +(defmethod is-int-struct-type? (x) + (declare (ignorable x)) + nil) + +(defun int-struct-accessor (sym) + (get sym 'int-struct-accessor)) + +(defmethod is-int-struct-constructor? ((sym symbol)) + (get sym 'int-struct-constructor-of)) + + +(defmethod is-int-struct-constructor? ((op cons)) + ;; For lambda exprs + nil) + +(def-int-struct int integer) +(progn . #.(loop for i from 1 to 64 + collect `(def-int-struct ,i (unsigned-byte ,i)))) +(progn . #.(loop for i from 2 to 64 + collect `(def-int-struct ,(format nil "~AS" i) (signed-byte ,i)))) + +;;; Class used for data + +(defclass rif-class-1 () + ((foo :initarg :foo :initform 0 :type integer)) + (:documentation "Class used for data in random-int-form")) + +(defclass rif-class-2 (rif-class-1) + ((bar :initarg :bar :initform 0 :type integer)) + (:documentation "Another class used for data in random-int-form")) + +(defclass rif-class-3 (rif-class-1) + ((baz :initarg :baz :initform 0 :type integer)) + (:documentation "Yet another class used for data in random-int-form")) + +;;; Execution of tests in multiple threads + +(defparameter *threads* nil + "List of threads created for random testing") + +#+sbcl +(defun begin-random-int-form-tests (nthreads &rest args) + (unless (boundp '$x) (setf $x nil)) + (unless (boundp '$y) (setf $y nil)) + (kill) + (setf *threads* nil) + (loop repeat nthreads + do (push (sb-thread:make-thread (lambda () (bind-and-call-lrif args))) *threads*))) + +#+sbcl +(defun kill () + (ignore-errors + (mapc #'sb-thread:terminate-thread *threads*)) + (setf *threads* nil)) + + +(defun bind-and-call-lrif (args) + (bind-and-call + (lambda () (apply #'loop-random-int-forms args)))) + +(defun bind-and-call (fn) + (let ((*random-int-form-progress-output* nil) + (*optimized-fn-src* nil) + (*unoptimized-fn-src* nil) + (*int-form-vals* nil) + (*opt-result* nil) + (*unopt-result* nil) + (*compile-unoptimized-form* *compile-unoptimized-form*) + (*make-random-integer-form-cdf* (copy-seq *default-make-random-integer-form-cdf*)) + *random-int-form-blocks* + *random-int-form-catch-tags* + *go-tags* + (*max-compile-time* 0) + (*max-compile-term* nil) + *vars* + *require-type-passed* + ) + (funcall fn))) + ;;; 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) +(declaim (special *file-lam*)) + +(defparameter *in-file* nil + "When true, COMPILE* defaults to file compilation") + +(defun compile* (lam &key (in-file *in-file*)) + (if in-file + (let ((name "tmp.lsp")) + (with-open-file (s name :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (let ((*package* (find-package :cl-test)) + (*print-readably* t) (*print-circle* t)) + (format s "~s~%" '(in-package :cl-test)) + (format s "(defparameter *file-lam* ~s)~%" lam) + (finish-output s))) + (multiple-value-bind (fasl warning-p error-p) + (compile-file name) + (declare (ignore warning-p)) + (when error-p + (error "Error when file compiling ~s" lam)) + (load fasl) + *file-lam*)) + (compile nil lam))) + (defun f (i) (let ((plist (elt $y i))) - (apply (compile nil (getf plist :optimized-lambda-form)) + (apply (compile* (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)) + (apply (compile* (getf plist :unoptimized-lambda-form)) (getf plist :vals)) (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) (getf plist :vals))))) @@ -84,6 +252,14 @@ (defmacro cl-handler-case (&rest args) `(cl:handler-case ,@args)) +;; Condition type for internal test failures + +(define-condition internal-test-failure (simple-error) + () + (:documentation "Errors internal to the testing process, +indicating a problem with that process rather than an error +in the thing being tested. Should not count as a test failure.")) + (eval-when (:compile-toplevel :load-toplevel :execute) (defun cumulate (vec) @@ -91,75 +267,199 @@ do (incf (aref vec i) (aref vec (1- i)))) vec)) +(defstruct symbol-distribution + pdf ;; Alist of positive integers . symbols + symbols ;; Vector of the symbols in PDF + cdf ;; CDF derived from the integers in the cars of the alist pdf +) + +(defun choose-from-symbol-distribution (sd) + (assert (typep sd 'symbol-distribution)) + (let ((a (symbol-distribution-cdf sd))) + (unless a + (let* ((pdf (symbol-distribution-pdf sd)) + (len (length pdf)) + (syms (mapcar #'cdr pdf))) + (dolist (x pdf) (assert (typep x '(cons (integer 0) symbol)))) + (setf a (make-array (list len) :initial-contents (mapcar #'cdr pdf))) + (cumulate a) + (setf (symbol-distribution-cdf sd) a) + (setf (symbol-distribution-symbols sd) syms))) + (let* ((len (length a)) + (max (aref a (1- len))) + (r (random max))) + ;; Maybe do binary search, but too lazy now + (loop for i from 0 + do (when (< r (aref a i)) + (aref (symbol-distribution-symbols sd) i)))))) + (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)))) + (cumulate (copy-seq #(10 ;; flet call + 5 ;; aref + 40 ;; unary ops + 4 ;; unwind-protect + #+random-mapping-forms 5 ;; mapping forms + 4 ;; prog1, multiple-value-prog1 + 2 ;; prog2 + 2 ;;isqrt + 10 ;; (the integer ...) + 1 ;; handler-bind + 1 ;; restart-bind + #-armedbear 1 ;; macrolet + #-armedbear 1;; symbol-macrolet + #-allegro 5 ;; dotimes + 50 ;; loop + 5 ;; count + #-(or cclasp mutation gcl ecl armedbear) 2 ;; load-time-value + 2 ;; eval + #-(or mutation cmu allegro poplog) 5 ;; ash + 4 ;; floor, ceiling, truncate, round (binary) + 30 ;; general binary ops + 4 ;; boole + 20 ;; n-ary ops + #-mutation 3 ;; expt + 2 ;; coerce + #-cclasp 2 ;; complex (degenerate case) + 1 ;; quotient (1) + 1 ;; quotient (-1) + 50 ;; tagbody + 60 ;; conditional + #-(or mutation poplog) 5 ;; deposit-field, dpb + #-(or mutation allegro poplog) 10 ;; ldb, mask-field + 50 ;; binding form + 4 ;; progv + 4 ;; (let () ...) + 10 ;; block + 20 ;; catch + 10 ;; setq and similar + 50 ;; case form + 3 ;; return-from + 20 ;; catch + 5 #-(or armedbear) 20 + 2 2 2 + 5 ;; identity-notinline + 4 ;; fn-with-state + #+sbcl + 2 ;; Example of sb ffi call + 10 ;; m-v-b-if + #-abcl 5 ;; inlined lambda + 10 ;; stacked comparisons + 20 ;; Non-integer forms (only when TOP? is true) + )))) (defparameter *make-random-integer-form-cdf* (copy-seq *default-make-random-integer-form-cdf*)) (eval-when (:compile-toplevel :load-toplevel :execute) + ;; Create random weight instead of using the default ones (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))) + (,vec (make-array ,len :initial-element 0))) + #| (loop for i from 0 below ,len do (setf (aref ,vec i) (1+ (min (random 100) (random 100))))) + |# + (loop repeat 15 + do (let ((i (random ,len))) + (setf (aref ,vec i) (random 100)))) (setq ,vec (cumulate ,vec)) (let ((*make-random-integer-form-cdf* ,vec)) ,@forms))))) +(defun identity-notinline (x) x) +(declaim (notinline identity-notinline)) + +;; Macro used to get values out from worker threads +(defmacro atomic-append-to (var tail) + #+sbcl + `(sb-thread:with-mutex (*mutex*) + (setf ,var (append ,var ,tail))) + #-sbcl + `(setf ,var (append ,var ,tail))) + ;;; Run the random tester, collecting failures into the special ;;; variable $y. -(defun loop-random-int-forms (&optional (size 200) (nvars 3)) +(defun loop-random-int-forms (&optional (size 200) (nvars 3) (max-iter nil) + (int-form-fn #'make-random-form)) (unless (boundp '$x) (setq $x nil)) (unless (boundp '$y) (setq $y nil)) (loop for i from 1 + while (or (null max-iter) (>= max-iter i)) do - (format t "~6D | " i) - (finish-output *standard-output*) + (when *random-int-form-progress-output* + (format t "~:[ ~;*~]~6D | " $x i) + (finish-output *standard-output*)) + ;; Under WSL, interrupts sometimes become disabled. + ;; Throwing and catching an error clears this. + #+sbcl + (handler-case (error "foo") (error ())) (let ((x (test-random-integer-forms size nvars *loop-random-int-form-period* - :index (* (1- i) *loop-random-int-form-period*)))) + :index (* (1- i) *loop-random-int-form-period*) + :int-form-fn int-form-fn + ))) (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*)) + (atomic-append-to $x x) + (let ((pruned-x (prune-results x))) + (terpri) (print pruned-x) (finish-output *standard-output*) + (atomic-append-to $y pruned-x) + )) + (when *random-int-form-progress-output* + (terpri))))) (defstruct var-desc (name nil :type symbol) (type t)) +(defmacro int-restrict (form tp) + (cond + ((member tp '(integer (integer) (integer *) (integer * *)) :test 'equal) + form) + ((and (consp tp) (eql (car tp) 'integer) (integerp (cadr tp)) (integerp (caddr tp))) + (let ((lo (cadr tp)) + (hi (caddr tp))) + `(min ,hi (max ,lo ,form)))) + (t (error "Cannot handle this type in int-restrict: ~A" tp)))) + +(define-condition innocuous-failure (simple-condition) () + (:documentation "Failures that, when they occur, do not indicate the test failed")) + +(define-condition require-failure (innocuous-failure) () + (:documentation "Error signalled by REQUIRE-TYPE when the value is not of the specified +type. This is intended to indicate that the test is bogus, not failed.")) + +(defparameter *require-type-passed* t + "Set to true when CHECK-REQUIRE-TYPE succeeded. Used to indicate that checks +should be removed.") + +(defun check-require-type (v tp) + (if (typep v tp) + (setf *require-type-passed* t) + (signal (make-condition 'require-failure + :format-control "~a not of type ~a" + :format-arguments (list v tp))))) + +(defvar *no-require-type* nil + "Controls whether REQUIRE-TYPE inserts a type check or not") + +(defmacro require-type (form tp) + "When FORM is not of type TP, signal a REQUIRE-FAILURE condition that indicates +the test was bad. When the special variable *NO-REQUIRE-TYPE* is true, omit +the check." + (if *no-require-type* + form + (let ((form-var (gensym)) (tp-var (gensym))) + `(let ((,form-var ,form) + (,tp-var ',tp)) + (check-require-type ,form-var ,tp-var) + ,form-var)))) + (defun test-random-integer-forms (size nvars n &key ((:random-state *random-state*) (make-random-state t)) @@ -167,6 +467,7 @@ (index 0) (random-size nil) (random-nvars nil) + (int-form-fn #'make-random-integer-form) ) "Generate random integer forms of size SIZE with NVARS variables. @@ -174,12 +475,14 @@ is found between optimized and nonoptimize, notinlined code." (assert (integerp nvars)) - (assert (<= 1 nvars 26)) + (assert (<= 0 nvars 26)) + (assert (if random-nvars (> nvars 0) t)) (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) + do (when (and *random-int-form-progress-output* + (= (mod i 100) 0)) ;; #+sbcl (print "Do gc...") ;; #+sbcl (sb-ext::gc :full t) ;; #+lispworks-personal-edition (cl-user::normal-gc) @@ -188,25 +491,56 @@ (if random-size (1+ (random size)) size) (if random-nvars (1+ (random nvars)) nvars) :index (+ index i) - :file-prefix file-prefix))) + :file-prefix file-prefix + :int-form-fn int-form-fn + ))) (when result (let ((*print-readably* nil)) (format t "~%~A~%" (format nil "~S" (car result))) (finish-output *standard-output*))) result))) +(defun widen-integer-type (type) + "Expand types of the form (integer lo hi) into various random supertypes" + (if (and (consp type) + (eql (car type) 'integer) + (integerp (cadr type)) + (integerp (caddr type))) + (rcase + (5 t) + (1 'number) + (1 'real) + (1 'integer) + (1 `(integer ,(cadr type))) + (1 `(integer * ,(caddr type))) + (30 type)) + type)) + (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)) + (size nvars &key (index 0) (file-prefix "b") + (int-form-fn #'make-random-integer-form)) + (let* ((*previous-constants* nil) + (vars (make-vars nvars)) + (var-types (make-var-types nvars)) + #|(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 (loop repeat nvars + collect #'(lambda (range) + (rcase + (1 'boolean) + (2 + (let* ((range (make-random-integer-range)) + (lo (car range)) (hi (cadr range))) (assert (>= hi lo)) - `(integer ,lo ,hi))) - var-ranges)) - (form (let ((*vars* (loop for v in vars + `(integer ,lo ,hi))))))) + |# + (widened-var-types (mapcar #'widen-integer-type var-types)) + (form (make-form size :int-form-fn int-form-fn :vars vars :var-types var-types :nvars nvars)) + #| + (let ((*vars* (loop for v in vars for tp in var-types collect (make-var-desc :name v :type tp))) @@ -215,21 +549,14 @@ (*go-tags* nil) ) (with-random-integer-form-params - (make-random-integer-form (1+ (random size)))))) + (funcall int-form-fn (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))) + collect (mapcar #'make-random-element-of-type var-types))) (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) + (labels ((%print (s &aux (*print-pretty* nil)) (print `(defparameter *x* '(:vars ,vars :var-types ,var-types @@ -239,11 +566,61 @@ :form ,form)) s) (print '(load "c.lsp") s) - (finish-output s)) - ;; (cl-user::gc) - ;; (make-list 1000000) + (force-output s)) + (%print-to-file (name) + (with-open-file (s name + :direction :output :if-exists :supersede + :if-does-not-exist :create) + (%print s)))) + (case *print-immediately* + (:term (%print *standard-output*)) + (:single (%print-to-file (format nil "~A.lsp" file-prefix))) + ((nil)) + (t (%print-to-file (format nil "~A~A.lsp" file-prefix index))))) + (test-int-form form vars widened-var-types vals-list opt-decls-1 opt-decls-2))) + +(defun make-form (size &key (int-form-fn #'make-random-integer-form) vars var-types nvars) + (unless (and nvars (eql (length vars) nvars)) + (setf vars (make-vars nvars)) + (setf var-types (make-var-types nvars))) + (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) ) - (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) + (with-random-integer-form-params + (funcall int-form-fn (1+ (random size)))))) + +(defun make-vars (nvars) + (assert (typep nvars '(integer 0 25))) + (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)) + +(defun make-var-types (nvars) + (let ((bool? (coin))) + (loop repeat nvars + collect (if (and bool? (coin 3)) + 'boolean + (let* ((range (make-random-integer-range)) + (lo (car range)) + (hi (cadr range))) + (assert (>= hi lo)) + `(integer ,lo ,hi)))))) + +(defun tif (result) + (let* ((form (getf result :form)) + (vars (getf result :vars)) + (var-types (getf result :var-types)) + (vals-list (or (getf result :vals-list) + (list (getf result :vals)))) + (opt-decl-1 (getf result :decls1)) + (opt-decl-2 (getf result :decls2)) + (result2 (test-int-form form vars var-types + vals-list opt-decl-1 opt-decl-2))) + result2)) (defun make-random-optimize-settings () (loop for settings = (list* @@ -280,8 +657,6 @@ (declaim (special *flet-names*)) (defparameter *flet-names* nil) - - (defun random-var-desc () (loop (let* ((pos (random (length *vars*))) @@ -301,20 +676,49 @@ (or (eql (caddr type) 0) (null (caddr type))))) -(defun make-random-integer-form (size) - "Generate a random legal lisp form of size SIZE (roughly)." - +(defparameter *make-error-forms* nil + "When true, cause MAKE-RANDOM-INTEGER-FORM to sometimes +generate (COMPILE-TIME-ERROR) form. The presence of this form +causes the compiler to abort, so the pruner should simplify +the form to just it. If this does not happen, the pruner could +be improved. If this variable is a real in the range [0,1] then +use it as a probability for actually generating an error +form, multiplied by the base probability.") + +(defmacro compile-time-error (&rest args) + (declare (ignore args)) + (error "Compile time error")) + +(defun make-random-form (size) + (make-random-integer-form size t)) + +(defun make-random-integer-form (size &optional top?) + "Generate a random legal lisp form of size SIZE (roughly). +If TOP? is true the value needn't be an integer, so relax +the constraints a bit." (if (<= size 1) ;; Leaf node -- generate a variable, constant, or flet function call (loop when (rcase - (10 (make-random-integer)) + ;; Generate error forms to test the pruner + (1 (when (and *make-error-forms* + (or (not (typep *make-error-forms* '(real 0 1))) + (<= (random 1.0) *make-error-forms*))) + '(compile-time-error))) + (10 + (if (and *previous-constants* (coin 3)) + (random-from-seq *previous-constants*) + (let ((i (make-random-integer))) + (push i *previous-constants*) + i))) (9 (if *vars* (let* ((desc (random-var-desc)) (type (var-desc-type desc)) (name (var-desc-name desc))) (cond + ((is-int-struct-type? type) + `(,(int-struct-accessor type) ,name)) ((subtypep type 'integer) name) (; (subtypep type '(array integer 0)) (is-zero-rank-integer-array-type type) @@ -322,9 +726,16 @@ ((subtypep type '(cons integer integer)) (rcase (1 `(car ,name)) (1 `(cdr ,name)))) + ((subtypep type 'boolean) + (let ((v1 (make-random-integer)) + (v2 (make-random-integer))) + `(if ,name ,v1 ,v2))) (t nil))) nil)) - (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) + (1 (if *innocuous-failures* + `(error 'innocuous-failure) + nil)) + (5 (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)) @@ -356,32 +767,39 @@ locally)))) `(,op ,(make-random-integer-form (1- size)))) - (make-random-integer-unwind-protect-form size) + (make-random-integer-unwind-protect-form size top?) + + ;; These were causing timeouts in some large functions, + ;; so I've conditionalized it + #+random-mapping-forms (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)) + (arg1 (make-random-integer-form (first sizes) top?)) + (other-args (mapcar #'make-random-form (cdr sizes)))) + `(,op ,arg1 ,@other-args)) ;; prog2 (let* ((nforms (random 4)) (sizes (random-partition (1- size) (+ nforms 2))) - (args (mapcar #'make-random-integer-form sizes))) - `(prog2 ,@args)) + (arg1 (make-random-form (first sizes))) + (arg2 (make-random-integer-form (second sizes) top?)) + (other-args (mapcar #'make-random-form (cddr sizes)))) + `(prog2 ,arg1 ,arg2 ,@other-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))) + `(cl:handler-bind nil ,(make-random-integer-form (1- size) top?)) + `(restart-bind nil ,(make-random-integer-form (1- size) top?)) #-armedbear - `(macrolet () ,(make-random-integer-form (1- size))) + `(macrolet () ,(make-random-integer-form (1- size) top?)) #-armedbear - `(symbol-macrolet () ,(make-random-integer-form (1- size))) + `(symbol-macrolet () ,(make-random-integer-form (1- size) top?)) ;; dotimes #-allegro @@ -390,17 +808,17 @@ (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)))) + (make-random-form (first sizes)))) + (ret-form (make-random-integer-form (second sizes) top?))) (unless (consp body) (setq body `(progn ,body))) `(dotimes (,var ,count ,ret-form) ,body)) ;; loop - (make-random-loop-form (1- size)) + (make-random-loop-form (1- size) top?) (make-random-count-form size) - #-(or gcl ecl armedbear) + #-(or cclasp mutation gcl ecl armedbear) ;; load-time-value (let ((arg (let ((*flet-names* nil) (*vars* nil) @@ -414,9 +832,9 @@ (2 `(load-time-value ,arg nil)))) ;; eval - (make-random-integer-eval-form size) + (make-random-integer-eval-form size top?) - #-(or cmu allegro poplog) + #-(or mutation cmu allegro poplog) (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(ash ,(make-random-integer-form s1) @@ -473,12 +891,14 @@ `(,op ,@args)) ;; expt + #-mutation `(expt ,(make-random-integer-form (1- size)) ,(random 3)) ;; coerce `(coerce ,(make-random-integer-form (1- size)) 'integer) ;; complex (degenerate case) + #-cclasp `(complex ,(make-random-integer-form (1- size)) 0) ;; quotient (degenerate cases) @@ -486,75 +906,75 @@ `(/ ,(make-random-integer-form (1- size)) -1) ;; tagbody - (make-random-tagbody-and-progn size) + (make-random-tagbody-and-progn size top?) ;; 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))) + (then-part (make-random-integer-form then-size top?)) + (else-part (make-random-integer-form else-size top?))) `(if ,pred ,then-part ,else-part)) - #-poplog + #-(or poplog mutation) (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) + #-(or mutation 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) + (make-random-integer-binding-form size top?) ;; progv - (make-random-integer-progv-form size) + (make-random-integer-progv-form size top?) `(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)))) + `(block ,name ,(make-random-integer-form (1- size) top?))) (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)))) + `(catch ,tag ,(make-random-integer-form (1- size) top?))) ;; setq and similar (make-random-integer-setq-form size) - (make-random-integer-case-form size) + (make-random-integer-case-form size top?) (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)) + (make-random-integer-form size top?)) (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)) + (make-random-integer-form size top?)) (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))) + (else (make-random-integer-form s3 top?))) `(if ,pred (return-from ,name ,then) ,else))) ;; No blocks -- try again - (make-random-integer-form size)) + (make-random-integer-form size top?)) #-(or armedbear) - (make-random-flet-form size) + (make-random-flet-form size top?) (let* ((nbits (1+ (min (random 20) (random 20)))) (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) @@ -573,8 +993,39 @@ (op 'elt)) `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) + `(identity-notinline ,(make-random-integer-form (1- size) top?)) + + `(fn-with-state ,(make-random-integer-form (1- size))) + + #+sbcl + (if (< size 3) + (sb-alien:alien-funcall + (sb-alien:extern-alien "os_get_errno" (function sb-alien:int))) + (make-random-integer-form size)) + + ;; mvb-if + (make-random-mvb-if-form size top?) + + ;; inlined lambda + #-abcl + (make-random-inline-lambda-form size top?) + + ;; Stacked comparisons + (make-stacked-comparison-form size top?) + + ;; Non-integer forms + (if top? (make-possibly-non-integer-form size) + (make-random-integer-form size)) + ))) +(defun make-possibly-non-integer-form (size) + (let* ((cond-size (random (max 1 (floor size 2)))) + (cond (make-random-pred-form cond-size)) + (body-form (make-random-form (- size cond-size))) + (op (rcase (1 'when) (1 'unless)))) + `(,op ,cond ,body-form))) + (defun make-random-aref-form (size) (or (when *vars* @@ -640,11 +1091,11 @@ (t (make-random-integer-form size)))) (make-random-integer-form size))) -(defun make-random-integer-unwind-protect-form (size) +(defun make-random-integer-unwind-protect-form (size top?) (let* ((op 'unwind-protect) (nforms (random 4)) (sizes (random-partition (1- size) (1+ nforms))) - (arg (make-random-integer-form (first sizes))) + (arg (make-random-integer-form (first sizes) top?)) (unwind-forms ;; We have to be careful not to generate code that will ;; illegally transfer control to a dead location @@ -652,10 +1103,10 @@ (*go-tags* nil) (*random-int-form-blocks* nil) (*random-int-form-catch-tags* nil)) - (mapcar #'make-random-integer-form (rest sizes))))) + (mapcar #'make-random-form (rest sizes))))) `(,op ,arg ,@unwind-forms))) -(defun make-random-integer-eval-form (size) +(defun make-random-integer-eval-form (size top?) (flet ((%arg (size) (let ((*flet-names* nil) (*vars* (remove-if-not #'(lambda (s) @@ -664,7 +1115,7 @@ *vars*)) (*random-int-form-blocks* nil) (*go-tags* nil)) - (make-random-integer-form size)))) + (make-random-integer-form size top?)))) (rcase (2 `(eval ',(%arg (1- size)))) (2 (let* ((nargs (1+ (random 4))) @@ -681,10 +1132,12 @@ (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase - (4 '(integer * *)) + (8 '(integer * *)) + #-mutation (1 (setq e1 `(make-array nil :initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) '(array integer nil)) + #-mutation (1 (let ((size (1+ (random 10)))) (setq e1 `(make-array '(,size):initial-element ,e1 ,@(rcase (1 nil) (1 '(:adjustable t))))) @@ -696,6 +1149,25 @@ ,@(rcase (1 nil) (1 '(:adjustable t))))) `(array integer (,size1 ,size2)))) |# + #+(or) + (1 (setq e1 `(make-rif-struct-int :n ,e1)) + 'rif-struct-int) + (1 (let* ((struct-descriptor (random-from-seq *int-structs*)) + (name (car struct-descriptor)) + (constructor (cadr struct-descriptor)) + (fields (cddr struct-descriptor)) + (field (random-from-seq fields))) + (destructuring-bind (initarg accessor type) + field + (declare (ignore accessor)) + (let* ((value (make-random-element-of-type type)) + (value-form (if (or (consp value) + (and (symbolp value) + (not (constantp value)))) + `(quote ,value) + value))) + (setq e1 `(,constructor ,initarg ,value-form)) + name)))) (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) '(cons integer integer)) (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) @@ -708,7 +1180,42 @@ (defun random-from-seq2 (seq) (elt seq (random2 (length seq)))) -(defun make-random-integer-binding-form (size) +(defmacro mvb-if (vars pred true-exprs false-exprs &body body) + (assert (listp vars)) + (assert (every #'symbolp vars)) + (assert (listp true-exprs)) + (assert (listp false-exprs)) + (assert (= (length vars) (length true-exprs) (length false-exprs))) + `(multiple-value-bind ,vars + (if ,pred + (values ,@true-exprs) + (values ,@false-exprs)) + ,@body)) + +(defun make-random-mvb-if-form (size top?) + (let* ((nvars (+ 2 (random 3))) + (vars (let ((var-list '(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) + (loop repeat nvars + collect (let ((v (random-from-seq var-list))) + (setq var-list (remove v var-list)) + v))))) + (destructuring-bind (sh sb) + (random-partition (1- size) 2) + (destructuring-bind (sp s1 s2) + (random-partition sh 3) + (let* ((true-sizes (random-partition s1 nvars)) + (false-sizes (random-partition s2 nvars)) + (pred (make-random-pred-form sp)) + (true-exprs (mapcar #'make-random-integer-form true-sizes)) + (false-exprs (mapcar #'make-random-integer-form false-sizes)) + (body-expr (let ((*vars* (append + (loop for v in vars + collect (make-var-desc :name v :type 'integer)) + *vars*))) + (make-random-integer-form sb top?)))) + `(mvb-if ,vars ,pred ,true-exprs ,false-exprs ,body-expr)))))) + +(defun make-random-integer-binding-form (size top?) (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)) @@ -721,7 +1228,7 @@ type2)) (e2 (let ((*vars* (cons (make-var-desc :name var :type type) *vars*))) - (make-random-integer-form s2))) + (make-random-integer-form s2 top?))) (op (random-from-seq #(let let*)))) ;; for now, avoid shadowing (if (member var *vars* :key #'var-desc-name) @@ -733,7 +1240,65 @@ ,e2)) (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) -(defun make-random-integer-progv-form (size) +(defun make-random-inline-lambda-form (size top?) + (destructuring-bind (sform svars) (random-partition (1- size) 2) + (let* ((nvars (random 4)) + (vars (let ((seq '(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) + (assert (<= nvars (length seq))) + (loop repeat nvars + collect (let ((x (random-from-seq seq))) + (setf seq (remove x seq)) + x)))) + (var-sizes (when (> nvars 0) (random-partition svars nvars))) + (arg-exprs (mapcar #'make-random-integer-form var-sizes)) + (e1 (let ((*vars* + (append (mapcar (lambda (v) (make-var-desc :name v :type 'integer)) vars) + *vars*))) + (make-random-integer-form sform top?))) + (rest? (coin 2))) + `((lambda (,@vars ,@(when rest? '(&rest args))) + ,e1) + ,@arg-exprs)))) + +(defun make-stacked-comparison-form (size top?) + "This exercises compiler optimizations that remove redundant comparisons +of the same values" + (let* ((sizes (random-partition (max 5 (1- size)) 5)) + (vars '#(v1 v2 v3 v4 v5 v6 v7 v8 v9)) + (v1 (random-from-seq vars)) + (v2 (loop (let ((x (random-from-seq vars))) + (unless (eql v1 x) (return x))))) + (op1 (random-from-seq #(= /= < <= > >=))) + (op2 (random-from-seq #(= /= < <= > >=))) + (f1 (make-random-integer-form (car sizes))) + (f2 (make-random-integer-form (cadr sizes))) + (forms (let ((*vars* + (list* (make-var-desc :name v1 :type 'integer) + (make-var-desc :name v2 :type 'integer) + *vars*))) + (mapcar (lambda (s) (make-random-integer-form s top?)) + (cddr sizes))))) + (flet ((%c (op) + (if (coin) + `(,op ,v1 ,v2) + `(,op ,v2 ,v1)))) + (destructuring-bind (f3 f4 f5) + forms + (if (coin 2) + `(let ((,v1 ,f1) + (,v2 ,f2)) + (if ,(%c op1) + (if ,(%c op2) + ,f3 ,f4) + ,f5)) + `(let ((,v1 ,f1) + (,v2 ,f2)) + (if ,(%c op1) + ,f3 + (if ,(%c op2) + ,f4 ,f5)))))))) + +(defun make-random-integer-progv-form (size top?) (let* ((num-vars (random 4)) (possible-vars *random-special-vars*) (vars nil)) @@ -753,7 +1318,7 @@ (*vars* (append (loop for v in vars collect (make-var-desc :name v :type '(integer * *))) *vars*)) - (body-form (make-random-integer-form s2))) + (body-form (make-random-integer-form s2 top?))) `(progv ',vars (list ,@var-forms) ,body-form)))))) (defun make-random-integer-mapping-form (size) @@ -828,7 +1393,11 @@ (1 (setq op 'multiple-value-setq) (setq var (list var))) (5 nil)) - `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) + (rcase + (1 `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) + (1 `(,op ,var (int-restrict ,(make-random-integer-form (1- size)) ,type))) + (1 `(,op ,var (require-type ,(make-random-integer-form (1- size)) ,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) @@ -859,8 +1428,11 @@ (make-random-integer-form size))) -(defun make-random-integer-case-form (size) - (let ((ncases (1+ (random 10)))) +(defun make-random-integer-case-form (size top?) + (let ((ncases (1+ (random 10))) + (non-int-rate (rcase (1 0.0) (1 (min (random 1.0) (random 1.0))))) + (non-int-type (random-from-seq #(base-char character symbol float complex + (or base-char character symbol float complex))))) (if (< (+ size size) (+ ncases 2)) ;; Too small, give up (make-random-integer-form size) @@ -874,21 +1446,29 @@ (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) + collect (if (>= (random 1.0) non-int-rate) + (random-from-interval + upper-bound lower-bound) + (make-random-element-of-type + non-int-type))) + for result = (make-random-integer-form case-size top?) repeat ncases collect `(,vals ,result))) (expr (make-random-integer-form (first sizes)))) `(case ,expr ,@cases - (t ,(make-random-integer-form (second sizes)))))))) + (t ,(make-random-integer-form (second sizes) top?))))))) -(defun make-random-flet-form (size) +(defparameter +flet-symbols+ #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 + %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)) + +(defun is-flet-symbol (sym) + (find sym +flet-symbols+)) + +(defun make-random-flet-form (size top?) "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)))) + (let ((fname (random-from-seq +flet-symbols+))) (if (assoc fname *flet-names*) ;; Fail if the name is in use (make-random-integer-form size) @@ -923,7 +1503,18 @@ (make-random-integer-form s1))) (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) *flet-names*))) - (make-random-integer-form s2))) + (make-random-integer-form s2 top?))) + (decl-forms + (append + (rcase + (2 nil) + (1 `((declare (notinline ,fname)))) + (1 (when (<= (count-in-tree fname form2) 1) + `((declare (inline ,fname)))))) + #-gcl + (rcase + (2 nil) + (1 `((declare (dynamic-extent (function ,fname)))))))) (opt-forms (mapcar #'make-random-integer-form opt-sizes) )) (if opt-forms @@ -940,6 +1531,7 @@ (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) + ,@decl-forms ,form2) `(,op ((,fname (,@arg-names ,@(when keyarg-p @@ -950,10 +1542,11 @@ (when allow-other-keys '(&allow-other-keys)) ))) ,form1)) + ,@decl-forms ,form2)))))))) (defun make-random-tagbody (size) - (let* ((num-forms (random 6)) + (let* ((num-forms (random 12)) (tags nil)) (loop for i below num-forms do (loop for tag = (rcase @@ -970,16 +1563,16 @@ for i below num-forms for size in sizes collect (let ((*go-tags* (append tag-list *go-tags*))) - (make-random-integer-form size))))) + (make-random-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) +(defun make-random-tagbody-and-progn (size top?) (let* ((final-size (random (max 1 (floor size 5)))) (tagbody-size (- size final-size))) - (let ((final-form (make-random-integer-form final-size)) + (let ((final-form (make-random-integer-form final-size top?)) (tagbody-form (make-random-tagbody tagbody-size))) `(progn ,tagbody-form ,final-form)))) @@ -988,6 +1581,11 @@ (if (<= size 1) (rcase (1 (if (coin) t nil)) + (1 (let ((bool-vars (remove 'boolean *vars* :key #'var-desc-type + :test-not #'eql))) + (if bool-vars + (var-desc-name (random-from-seq bool-vars)) + (make-random-pred-form size)))) (2 `(,(random-from-seq '(< <= = > >= /= eql equal)) ,(make-random-integer-form size) @@ -1012,7 +1610,7 @@ (then-part (make-random-pred-form then-size)) (else-part (make-random-pred-form else-size))) `(if ,pred ,then-part ,else-part))) - #-poplog + #-(or mutation poplog) (1 (destructuring-bind (s1 s2) (random-partition (1- size) 2) `(ldb-test ,(make-random-byte-spec-form s1) @@ -1060,9 +1658,9 @@ `(typep ,subform ',type))) ))) -(defun make-random-loop-form (size) +(defun make-random-loop-form (size top?) (if (<= size 2) - (make-random-integer-form size) + (make-random-integer-form size top?) (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) (count (random 4)) (*vars* (cons (make-var-desc :name var :type nil) @@ -1078,22 +1676,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 'satisfies)) type-args) + (assert (= (length type-args) 1)) + (ecase (car type-args) + (eval (make-random-element-of-type '(and t (not list)))) + (identity (make-random-element-of-type '(and t (not null)))) + (null nil) + (t (make-random-element-of-type `(and t (satisfies ,(car 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)) + (let ((len (length type-args))) + (block done + (loop for i from 0 below len + do (let ((tp (elt type-args i)) + (rest (remove-nth type-args i))) + (loop for x = (make-random-element-of-type tp) 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)))) + do (when (typep x (cons 'and rest)) + (return-from done x)))) + finally (let ((e (make-condition 'internal-test-failure + :format-control "Cannot generate random element of ~A" + :format-arguments (list (cons type-op type-args))))) + (error e)))))) (:method ((type-op (eql 'not)) type-args) (assert (eql (length type-args) 1)) (make-random-element-of-type `(and t (not ,(car type-args))))) @@ -1131,7 +1740,8 @@ (hi (cadr type-args)) lo= hi=) (cond - ((consp lo) nil) + ((consp lo) + (setq lo (car lo))) ((member lo '(* nil)) (setq lo nil) (setq lo= nil)) @@ -1139,7 +1749,8 @@ (assert (typep lo 'rational)) (setq lo= t))) (cond - ((consp hi) nil) + ((consp hi) + (setq hi (car hi))) ((member hi '(* nil)) (setq hi nil) (setq hi= nil)) @@ -1148,6 +1759,7 @@ (setq hi= t))) (assert (or (null lo) (null hi) (<= lo hi))) (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (let ((result (cond ((null lo) (cond @@ -1159,7 +1771,10 @@ (lo= (+ lo (make-random-nonnegative-rational))) (t (+ lo (make-random-positive-rational))))) (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))) + (if (typep result `(rational ,@type-args)) + result + (make-random-element-of-compound-type type-op type-args))))))) (:method ((type-op (eql 'ratio)) type-args) (let ((r 0)) @@ -1217,7 +1832,7 @@ (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'mod)) type-args) - (let ((modulus (second type-args))) + (let ((modulus (first type-args))) (assert (integerp modulus)) (assert (plusp modulus)) (make-random-element-of-compound-type 'integer `(0 (,modulus))))) @@ -1260,7 +1875,7 @@ (size-spec (if (cdr type-args) (cadr type-args) '*))) (make-random-vector etype-spec size-spec))) - (:method ((type-op (eql 'aimple-vector)) type-args) + (:method ((type-op (eql 'simple-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))) @@ -1332,7 +1947,9 @@ (defun make-random-element-of-float-type (type-op &optional lo hi) (let (lo= hi=) (cond - ((consp lo) nil) + ((consp lo) + (setf lo (car lo)) + (assert (realp lo))) ((member lo '(* nil)) (setq lo (most-negative-float type-op)) (setq lo= t)) @@ -1340,7 +1957,9 @@ (assert (typep lo type-op)) (setq lo= t))) (cond - ((consp hi) nil) + ((consp hi) + (setf hi (car hi)) + (assert (realp hi))) ((member hi '(* nil)) (setq hi (most-positive-float type-op)) (setq hi= t)) @@ -1591,6 +2210,8 @@ (defmethod make-random-element-of-type ((type class)) (make-random-element-of-type (class-name type))) +(defmethod make-random-element-of-type ((type (eql 'package))) + (find-package (random-from-seq #(:keyword :cl-user :cl :cl-test)))) (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))) @@ -1649,6 +2270,11 @@ (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 'bignum))) + (let ((m (ash 1 (random 32)))) + (if (coin) + (+ most-positive-fixnum 1 (random m)) + (- most-negative-fixnum 1 (random m))))) (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))) @@ -1680,6 +2306,58 @@ (t (call-next-method type)) )) +(defmethod make-random-element-of-type ((type (eql 'structure-object))) + (make-random-element-of-type (car (random-from-seq *int-structs*)))) + +(defmethod make-random-element-of-type ((type (eql t))) + (make-random-element-of-type + (rcase + (10 'real) + (10 'symbol) + (10 'boolean) + (10 (rcase + (1 'integer) + (1 '(integer 0)) + (1 `(unsigned-byte ,(1+ (random 32)))) + (1 `(signed-byte ,(1+ (random 32)))))) + #-ecl + (3 (rcase + (1 'complex) + (1 '(complex single-float)) + (1 '(complex double-float)))) + (3 'base-char) + (2 'character) + (3 `(base-string ,(random 10))) + (2 `(string ,(random 10))) + (5 `(bit-vector ,(random 10))) + (10 '(or (cons t null) + (cons t (cons t null)) + (cons t (cons t (cons t null))))) + (5 '(vector t 1)) + (2 'package) + (3 (car (random-from-seq *int-structs*)))))) + +#+sbcl +(progn + (defmethod make-random-element-of-type ((type (eql 'sb-kernel:simple-character-string))) + (make-random-element-of-type 'simple-string)) + (defmethod make-random-element-of-type ((type (eql 'sb-kernel:complex-single-float))) + (make-random-element-of-type '(complex single-float))) + (defmethod make-random-element-of-type ((type (eql 'sb-kernel:complex-double-float))) + (make-random-element-of-type '(complex double-float))) + (defmethod make-random-element-of-type ((type (eql 'sb-kernel::character-string))) + (make-random-element-of-type 'string))) + +#+ccl +(progn + (defmethod make-random-element-of-type ((type (eql 'ccl::complex-single-float))) + (make-random-element-of-type '(complex single-float))) + (defmethod make-random-element-of-type ((type (eql 'ccl::complex-double-float))) + (make-random-element-of-type '(complex double-float))) + (defmethod make-random-element-of-type ((type (eql 'ccl::general-vector))) + (make-random-vector '* '*))) + + (defun make-random-character () (loop when (rcase @@ -1820,7 +2498,8 @@ (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning) - ((or error serious-condition) + ((and (or error serious-condition) + #+sbcl (not sb-sys:interactive-interrupt)) #'(lambda (c) (format t "Compilation failure~%~A~%" (format nil "~S" form)) @@ -1853,7 +2532,7 @@ ,@(cdr clf))) (compile opt-defun-name) (symbol-function opt-defun-name)) - (t (compile nil lambda-form))) + (t (compile* lambda-form))) (let* ((stop-time (get-universal-time)) (total-time (- stop-time start-time))) (when (> total-time *max-compile-time*) @@ -1864,9 +2543,26 @@ (let ((optimized-compiled-fn (%compile optimized-fn-src *name-to-use-in-optimized-defun*)) (unoptimized-compiled-fn + (cl:handler-case (if *compile-unoptimized-form* (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) - (eval `(function ,unoptimized-fn-src))))) + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (eval `(function ,unoptimized-fn-src)))) + (error (e) + (format t "Eval unoptimized-compiled-fn Error~A~%" unoptimized-fn-src) + (return-from test-int-form + (list (list :vars vars + :vals nil + :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 e))) + )))) (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) (dolist (vals vals-list) (setq *int-form-vals* vals) @@ -1892,7 +2588,12 @@ (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list - (apply unoptimized-compiled-fn vals))) + (let ((*fn-state* 0)) + (apply unoptimized-compiled-fn vals)))) + #+sbcl + (sb-sys:interactive-interrupt (e) (error e)) + (innocuous-failure () :bogus) + ;; (require-failure () :bogus) ((or error serious-condition) (c) (%eval-error (list :unoptimized-form-error @@ -1904,7 +2605,12 @@ (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) (identity ;; multiple-value-list - (apply optimized-compiled-fn vals))) + (let ((*fn-state* 0)) + (apply optimized-compiled-fn vals)))) + #+sbcl + (sb-sys:interactive-interrupt (e) (error e)) + (innocuous-failure () :bogus) + ;; (require-failure () :bogus) ((or error serious-condition) (c) (%eval-error (list :optimized-form-error @@ -1921,24 +2627,41 @@ opt-result unopt-result))))))))))) +(defun remove-nth (seq n) + (assert (listp seq) () "remove-nth only handles lists for now") + (assert (<= 0 n)) + (assert (< n (length seq))) + (append (subseq seq 0 n) + (subseq seq (1+ n)))) + +(defun replace-nth (seq val n) + (assert (listp seq) () "replace-nth only handles lists for now") + (assert (<= 0 n)) + (assert (< n (length seq))) + (append (subseq seq 0 n) + (list val) + (subseq seq (1+ n)))) + ;;; 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) +(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2 + &key (test-fn #'test-int-form)) "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 + (when (funcall test-fn + 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) + (prune form #'%try-fn t) (return form))))) (when (equal form input-form) (return form)) (setq input-form form)))) @@ -1967,6 +2690,70 @@ :optimized-lambda-form ,optimized-lambda-form :unoptimized-lambda-form ,unoptimized-lambda-form)))) +(defun prune-boolean (form try-fn &optional top?) + (declare (ignorable top?)) + (when (gethash form *prune-table*) + (return-from prune-boolean nil)) + (flet ((try (x) + ;; (format t "try ~A~%" x) + (funcall try-fn x))) + (typecase form + ((member nil t) nil) + (cons + (try t) + (try nil) + (let* ((op (car form)) + (args (cdr form)) + (nargs (length args))) + (case op + ((and or) + (mapc #'try args) + (loop for i from 0 below nargs + do (let ((s (remove-nth args i))) + (try `(,op ,@s)))) + (loop for i from 0 below nargs + for e in args + do (prune-boolean e + (lambda (form) + (try `(,op ,@(replace-nth args form i) + )))))) + ((not) + (try (car args)) + (prune-boolean (car args) (lambda (form) (try `(not ,form))))) + ((if) + (prune-fn form try-fn nil #'prune-boolean) + (dolist (e (cdr form)) + (try `(not ,e)))) + ((case) + (prune-case form try-fn)) + ((= /= < > <= >= evenp oddp minusp logbitp zerop equal eql eq + min max fn-with-state) + (mapc #'try args) + (prune-fn form try-fn)) + ((block) + (assert (>= nargs 1)) + (when (> nargs 1) + (let ((tag (car args))) + (unless (find-in-tree tag (cdr args)) + (try (cadr args))) + (prune (cadr args) + (lambda (form) `(block ,tag ,form)))))) + (typep + (try (car args)) + (prune (car args) + #'(lambda (form) (try `(,op ,form ,@(cdr args)))))) + (position + (assert (>= nargs 2)) + (try (car args)) + (prune (car args) (lambda (form) (try `(,op ,form ,@(cdr args)))))) + (otherwise + (when (and (consp (car form)) (eql (caar form) 'lambda)) + (prune-inline-lambda-form form try-fn))) + ))) + (otherwise + (try t) + (try nil))))) + ;;; ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form ;;; so that it still satisfies TRY-FN. The function TRY-FN should @@ -1975,11 +2762,13 @@ ;;; ;;; The return value of PRUNE should be ignored. ;;; -(defun prune (form try-fn) +(defun prune (form try-fn &optional top?) (declare (type function try-fn)) (when (gethash form *prune-table*) (return-from prune nil)) - (flet ((try (x) (funcall try-fn x))) + (flet ((try (x) + ;; (format t "try ~A~%" x) + (funcall try-fn x))) (cond ((keywordp form) nil) ((integerp form) @@ -1988,20 +2777,92 @@ (let* ((op (car form)) (args (cdr form)) (nargs (length args))) + ;; (format t "OP: ~A~%" op) (case op + #+sbcl + ((sb-alien:alien-funcall) + (try 0)) + + ((count) + (assert (>= nargs 2)) + (try 0) + (try (car args)) + (prune (car args) + (lambda (form) + (try `(,op ,form ,@(cdr args)))))) + + ((mvb-if) + (try 0) + (destructuring-bind (vars pred true-exprs false-exprs body-expr) + args + (try `(let* ,(mapcar #'list vars true-exprs) ,body-expr)) + (try `(let* ,(mapcar #'list vars false-exprs) ,body-expr)) + (prune-boolean pred + #'(lambda (p) (try `(mvb-if ,vars ,p + ,true-exprs ,false-exprs + ,body-expr)))) + (unless (find-any-in-tree vars pred) + (try `(if ,pred 0 0))) + (prune body-expr + #'(lambda (form) + (try `(mvb-if ,vars ,pred ,true-exprs ,false-exprs ,form)))) + (loop for i from 0 + for e in false-exprs + do (prune e + #'(lambda (form) + (try `(mvb-if ,vars ,pred + ,true-exprs + ,(replace-nth false-exprs form i) + ,body-expr))))) + (loop for i from 0 + for e in true-exprs + do (prune e + #'(lambda (form) + (try `(mvb-if ,vars ,pred + ,(replace-nth true-exprs form i) + ,false-exprs + ,body-expr))))) + )) + + ((quote) nil) + ((dxf) nil) + + ((make-rif-struct) + (when (and (= nargs 2) (eql (car args) :n)) + (prune (cadr args) + #'(lambda (form) (try `(make-rif-struct :n ,form)))))) + ((go) (try 0)) ((signum integer-length logcount logandc1 logandc2 lognand lognor logorc1 logorc2 - realpart imagpart) + realpart imagpart identity-notinline identity) (try 0) (mapc try-fn args) (prune-fn form try-fn)) + ((int-restrict require-type) + (assert (= nargs 2)) + (let ((form (car args)) + (tp (cadr args))) + (when (typep 0 tp) (try 0)) + (cond + ((or top? (member tp '(integer (integer) (integer *) (integer * *)) :test 'equal)) + (try form)) + ((and (integerp form) (typep form tp)) + (try form)) + ((and (consp tp) (eql (car tp) 'integer) (integerp (cadr tp)) (integerp (caddr tp))) + (let ((lo (cadr tp)) + (hi (caddr tp))) + (try lo) + (when (< lo hi) + (try hi))))) + (prune form #'(lambda (form) (try `(,op ,form ,tp)))))) + ((make-array) (when (and (eq (car args) nil) (eq (cadr args) ':initial-element) @@ -2012,8 +2873,8 @@ (try `(make-array nil :initial-element ,(caddr args)))) )) - ((cons) - (prune-fn form try-fn)) + ((cons list vector) + (prune-fn form try-fn top?)) ((dotimes) (try 0) @@ -2028,23 +2889,37 @@ (prune result #'(lambda (form) (try `(dotimes (,var ,count-form ,form) ,@body)))) (when (= (length body) 1) + (unless (find-in-tree var (car body)) + (try (car body))) (prune (first body) #'(lambda (form) (when (consp form) (try `(dotimes (,var ,count-form ,result) ,form)))))))) - ((abs 1+ 1-) + ((abs 1+ 1- fn-with-state) (try 0) (mapc try-fn args) (prune-fn form try-fn)) - ((identity ignore-errors cl:handler-case restart-case locally) + ((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)) + ((symbol-macrolet) + (when (and (consp args) + (null (car args))) + (mapc try-fn (cdr args))) + #+nil + (let ((len (length args))) + (loop for i from 1 below len + do (prune (elt args i) + #'(lambda (form) (try `(symbol-macrolet + ,@(replace-nth args form i) + ))))))) + ((boole) (try (second args)) (try (third args)) @@ -2055,6 +2930,7 @@ ((unwind-protect prog1 multiple-value-prog1) (try (first args)) + ;; (when top? (mapc try-fn (rest args))) (let ((val (first args)) (rest (rest args))) (when rest @@ -2063,30 +2939,34 @@ (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)) + ,@(remove-nth rest i) + )))))) + (prune-fn form try-fn top?)) ((prog2) - (assert (>= (length args) 2)) + (assert (>= nargs 2)) (let ((val1 (first args)) (arg2 (second args)) (rest (cddr args))) (try arg2) + (when top? + (try val1) + (mapc try-fn rest)) (prune-fn form try-fn) (when rest (try `(prog2 ,val1 ,arg2)) + (mapc #'try rest) (when (cdr rest) (loop for i from 0 below (length rest) do (try `(prog2 ,val1 ,arg2 - ,@(subseq rest 0 i) - ,@(subseq rest (1+ i))))))))) + ,@(remove-nth rest i) + ))))))) ((typep) (try (car args)) (prune (car args) - #'(lambda (form) `(,op ,form ,@(cdr args))))) + #'(lambda (form) (try `(,op ,form ,@(cdr args)))))) ((load-time-value) (let ((arg (first args))) @@ -2109,10 +2989,11 @@ ((consp arg) (cond ((eql (car arg) 'quote) + (try (cadr arg)) (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) (t (try arg) - (prune arg #'(lambda (form) `(eval ,form)))))) + (prune arg #'(lambda (form) (try `(eval ,form))))))) (t (try arg))))) ((the macrolet cl:handler-bind restart-bind) @@ -2138,6 +3019,10 @@ (prune-nary-fn form try-fn) (prune-fn form try-fn)) + ((complex conjugate) + (when args + (try (car args)))) + ((- + * min max logand logior logxor logeqv gcd lcm values) (when (every #'constantp args) (try (eval form))) @@ -2151,10 +3036,10 @@ (try (eval form))) (try 0) (try (car args)) - (when (cddr args) + (when (cadr args) (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) - ((expt rationalize rational numberator denominator) + ((expt rationalize rational numerator denominator) (try 0) (mapc try-fn args) (prune-fn form try-fn)) @@ -2189,9 +3074,16 @@ (when (= (length args) 2) (let ((arg1 (car args)) (arg2 (cadr args))) + (when (vectorp arg1) + (map nil try-fn arg1)) + (when (and (consp arg1) + (eql (car arg1) 'quote) + (listp (cadr arg1))) + (mapc try-fn (cadr arg1))) (when (and (consp arg2) (eql (car arg2) 'min) (integerp (cadr arg2))) + (try (cadr arg2)) (let ((arg2.2 (caddr arg2))) (try arg2.2) (when (and (consp arg2.2) @@ -2207,14 +3099,24 @@ (try 1)) ((if) - (let (;; (pred (first args)) + ;; (format t "prune if~%") + (let ((pred (first args)) (then (second args)) (else (third args))) + (when top? (try pred)) + ;; (format t "prune if then~%") (try then) + ;; (format t "prune if else~%") (try else) (when (every #'constantp args) (try (eval form))) - (prune-fn form try-fn))) + ;; (format t "prune if pred~%") + (prune-boolean pred + #'(lambda (e) + (try `(if ,e ,then ,else)))) + (prune then #'(lambda (e) (try `(if ,pred ,e ,else)))) + (prune else #'(lambda (e) (try `(if ,pred ,then ,e)))) + )) ((incf decf) (try 0) @@ -2325,6 +3227,13 @@ #'(lambda (x) (try `(block ,name ,x)))))))) + ((return-from) + (try 0) + (when (= nargs 2) + (try (second args)) + (prune (second args) (lambda (form) `(return-from ,(first args) ,form))))) + + ((catch) (let* ((tag (second form)) (name (if (consp tag) (cadr tag) tag)) @@ -2359,7 +3268,7 @@ ((flet labels) (try 0) - (prune-flet form try-fn)) + (prune-flet form try-fn top?)) ((case) (prune-case form try-fn)) @@ -2369,6 +3278,7 @@ (assert (null (cddr form))) (assert (consp arg)) (assert (eq (first arg) 'abs)) + ;; (format t "Trying...~%") (let ((arg2 (second arg))) (try arg2) ;; Try to fold @@ -2402,6 +3312,7 @@ ((floor ceiling truncate round mod rem) (try 0) + ;; (fn form1 form2) (let ((form1 (second form)) (form2 (third form))) (try form1) @@ -2417,6 +3328,7 @@ (member (first form2) '(max min)) (every #'integerp (cdr form2))) (try (eval form))) + ;; (fn form1 (fn2 form2.2 form3)) (let ((form3 (third form2))) (prune form3 #'(lambda (form) @@ -2509,11 +3421,12 @@ ((progn) (when (null args) (try nil)) - (try (car (last args))) + (if top? + (mapc try-fn args) + (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 (try `(progn ,@(remove-nth args i))) do (when (and (consp a) (or (eq (car a) 'progn) @@ -2540,6 +3453,8 @@ (try `(loop for ,var below ,count sum ,form))))) (count (unless (or (eql form t) (eql form nil)) + (when (and top? (not (find-in-tree var form))) + (try form)) (try `(loop for ,var below ,count count t)) (try `(loop for ,var below ,count count nil)) (prune form @@ -2548,20 +3463,93 @@ )))) (otherwise + (cond + ((is-int-struct-constructor? op) + (when (and (= nargs 2) (eql (car args) :n)) + (unless (eql (cadr args) 0) + (try `(,op ,(car args) 0))) + (prune (cadr args) + #'(lambda (form) (try `(,op ,(car args) ,form)))))) + ((is-flet-symbol op) + (dolist (e args) + (unless (keywordp e) (try e)))) + ((and (consp op) (eql (car op) 'lambda)) + (prune-inline-lambda-form form try-fn)) + (t (try 0) - (prune-fn form try-fn)) - + (prune-fn form try-fn top?)))) ))))) (setf (gethash form *prune-table*) t) nil) -(defun find-in-tree (value tree) +(defun prune-inline-lambda-form (form try-fn) + (prune-fn form try-fn) + (flet ((try (x) (funcall try-fn x))) + (let* ((lam (car form)) + (args (cdr form)) + (lam-list (cadr lam)) + (lam-list-vars + (loop for v in lam-list + when (and (symbolp v) (not (member v lambda-list-keywords))) + collect v + when (and (consp v) + (symbolp (car v))) + collect (car v) + when (and (consp v) (consp (cdr v)) (consp (cddr v)) + (third v) (symbolp (third v))) + collect (third v))) + (lam-expr (caddr lam))) + (assert (eql (car lam) 'lambda)) + ;; If the body of the lambda does not use any argument, try + ;; to eliminate the call + (mapc try-fn args) + (let ((e (third lam))) + (when (and e (not (stringp e)) + (not (and (consp e) (eql (car e) 'declare))) + (not (find-any-in-tree lam-list-vars e))) + (try `(progn ,@args ,e)))) + ;; Argument prunes are handled by the call to prune-fn + ;; Here, attempt prunes inside the lambda form + (when (and (>= (length lam-list) 2) + (eql (car (last lam-list 2)) '&rest)) + (try `((lambda ,(butlast lam-list 2) ,lam-expr) ,@args))) + (loop for i from 0 below (length args) + for v in lam-list + for lam-rest on lam-list + do (unless (or (not (symbolp v)) + (find-in-tree v (cdr lam-rest)) + (find-in-tree v lam-expr)) + (try `((lambda ,(remove-nth lam-list i) + ,lam-expr) + ,@(remove-nth args i) + )))) + (prune lam-expr (lambda (x) (try `((lambda ,lam-list ,x) ,@args))))))) + +(defun find-in-tree (value tree &key (test #'eql)) "Return true if VALUE is eql to a node in TREE." - (or (eql value tree) + (or (funcall test value tree) (and (consp tree) (or (find-in-tree value (car tree)) (find-in-tree value (cdr tree)))))) +(defun find-any-in-tree (vals tree) + "Return true if any element of the list VALS is EQL to a node in TREE" + (or (member tree vals) + (and (consp tree) + (or (find-any-in-tree vals (car tree)) + (find-any-in-tree vals (cdr tree)))))) + +(defun count-in-tree (value tree) + "Return the number of occurrence of things EQL to VALUE in TREE. + Assumes VALUE is not a CONS" + (cond + ((eql value tree) 1) + (t + (+ + (loop while (consp tree) + sum (count-in-tree value (pop tree))) + (if (eql value tree) 1 0))))) + (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." @@ -2571,37 +3559,56 @@ e #'(lambda (form) (funcall list-try-fn - (append (subseq list 0 i) - (list form) - (subseq list (1+ i)))))))) + (replace-nth list form i) + ))))) +#| +(defun prune-eval (args try-fn) + (flet ((try (e) (funcall try-fn e))) + (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)))))) +|# (defun prune-case (form try-fn) (declare (type function try-fn)) - (flet ((try (e) (funcall try-fn e))) + (flet ((try (e) + ;; (format t "prune-case try ~a~%" e) + (funcall try-fn e))) (let* ((op (first form)) (expr (second form)) (cases (cddr form))) ;; Try just the top expression + ;; (format t "prune-case just top expr~%") (try expr) ;; Try simplifying the expr + ;; (format t "prune-case simplify top expr~%") (prune expr #'(lambda (form) (try `(,op ,form ,@cases)))) ;; Try individual cases + ;; (format t "prune-case individual cases~%") (loop for case in cases do (try (first (last (rest case))))) ;; Try deleting individual cases + ;; (format t "prune-case deleting cases~%") (loop for i from 0 below (1- (length cases)) - do (try `(,op ,expr - ,@(subseq cases 0 i) - ,@(subseq cases (1+ i))))) + do (try `(,op ,expr ,@(remove-nth cases i)))) ;; Try simplifying the cases ;; Assume each case has a single form + ;; (format t "prune-case simplifying cases~%") (prune-list cases #'(lambda (case try-fn) (declare (type function try-fn)) @@ -2609,9 +3616,9 @@ (> (length (car case)) 1)) ;; try removing constants (loop for i below (length (car case)) + ;; do (format t "prune-case remove ~a~%" (elt (car case) i)) do (funcall try-fn - `((,@(subseq (car case) 0 i) - ,@(subseq (car case) (1+ i))) + `((,@(remove-nth (car case) i)) ,@(cdr case))))) (when (eql (length case) 2) (prune (cadr case) @@ -2623,30 +3630,33 @@ (defun prune-tagbody (form try-fn) (declare (type function try-fn)) - (let (;; (op (car form)) - (body (cdr form))) + (let* (;; (op (car form)) + (body (cdr form)) + (tags (remove-if-not #'atom body))) (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)))))) + (unless (find-in-tree `(go ,e) (subseq body 0 i) + :test #'equal) + (funcall try-fn `(tagbody ,@(remove-nth body i) + )))) (t + (unless (find-any-in-tree tags e) + (funcall try-fn e)) (funcall try-fn - `(tagbody ,@(subseq body 0 i) - ,@(subseq body (1+ i)))) + `(tagbody ,@(remove-nth body 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)))))))))))) + `(tagbody ,@(replace-nth body form i) + )))))))))) (defun prune-progv (form try-fn) (declare (type function try-fn)) @@ -2687,20 +3697,22 @@ (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))))))) + (loop for i from 0 below nargs + do (funcall try-fn `(,op ,@(remove-nth args i))))))) -(defun prune-fn (form try-fn) +(defun prune-fn (form try-fn &optional top? (prune-fn #'prune)) "Attempt to simplify a function call form. It is considered - acceptable to replace the call by one of its argument forms." + acceptable to replace the call by one of its argument forms. + If TOP? is true this is a top level form, so the pruned + form can return any type" (declare (type function try-fn)) + (when top? (mapc try-fn (cdr form))) (prune-list (cdr form) - #'prune + prune-fn #'(lambda (args) (funcall try-fn (cons (car form) args))))) -(defun prune-let (form try-fn) +(defun prune-let (form try-fn &optional top?) "Attempt to simplify a LET form." (declare (type function try-fn)) (let* ((op (car form)) @@ -2708,8 +3720,14 @@ (body (cddr form)) (body-len (length body)) (len (length binding-list)) + (vars (mapcar (lambda (b) (if (consp b) (car b) b)) binding-list)) ) + (when top? + (dolist (binding binding-list) + (when (consp binding) + (funcall try-fn (cadr binding))))) + (when (> body-len 1) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) @@ -2724,10 +3742,14 @@ (eql (car val-form) 'make-array)) (funcall try-fn val-form)))) |# + (when (and (>= len 1) + (= body-len 1) + (not (find-any-in-tree vars (car body)))) + (funcall try-fn (car body))) (when (>= len 1) (let ((val-form (cadar binding-list))) - (when (consp val-form) + (if (consp val-form) (case (car val-form) ((make-array) (let ((init (getf (cddr val-form) :initial-element))) @@ -2735,7 +3757,21 @@ (funcall try-fn init)))) ((cons) (funcall try-fn (cadr val-form)) - (funcall try-fn (caddr val-form))))))) + (funcall try-fn (caddr val-form))) + (t + (funcall try-fn val-form))) + (funcall try-fn val-form)))) + + ;; Try to split into multiple bindings + (when (and (> len 1) body) + (let ((body body)) + (loop while (and (cdr body) + (consp (car body)) + (eql (caar body) 'declare)) + do (pop body)) + (loop for binding in (reverse binding-list) + do (setf body `((let (,binding) ,@body)))) + (funcall try-fn (car body)))) ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list @@ -2749,15 +3785,26 @@ #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) - ;; Prune off unused variable + ;; Prune off unused variable -- just one binding + #+(or) (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))))) + (not (find-if-subtree (lambda (x) (eq x name)) body))))) (funcall try-fn `(progn ,@body))) + ;; Prune off unused variable -- more than one binding + (when (and binding-list + ;; (rest binding-list) + (let ((name (caar binding-list))) + (and (symbolp name) + (not (find-if-subtree (lambda (x) (eq x name)) + (cons (cdr binding-list) body)))))) + (funcall try-fn `(let ,(rest binding-list) ,@body))) + ;; Try to simplify the body of the LET form + ;; Bug in this? (when body (unless binding-list (funcall try-fn (car (last body)))) @@ -2769,17 +3816,28 @@ (has-binding-to-var (first binding) body) (has-assignment-to-var (first binding) body) ) - (funcall try-fn `(let () - ,@(subst (second binding) + (let ((newbody + (subst-except-for-eval + (second binding) (first binding) (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) - body) - )))))) + body)))) + (unless (find-in-tree (first binding) newbody) + (funcall try-fn `(let () ,@newbody))))))) + (prune (car (last body)) #'(lambda (form2) (funcall try-fn `(,@(butlast form) ,form2))))))) +(defun subst-except-for-eval (e var body) + "Like SUBST, but don't descend into EVAL forms" + (cond + ((eql body var) e) + ((not (consp body)) body) + ((eql (car body) 'eval) body) + (t (mapcar #'(lambda (b) (subst-except-for-eval e var b)) body)))) + (defun has-assignment-to-var (var form) (find-if-subtree #'(lambda (form) @@ -2796,14 +3854,30 @@ #'(lambda (form) (and (consp form) (case (car form) + ((lambda) + (loop for b in (cadr form) + thereis (or (eql b var) + (and (consp b) + (or (eql (car b) var) + (and (consp (cdr b)) + (consp (cddr b)) + (eql var (caddr b)))))))) + ((let let*) (loop for binding in (cadr form) thereis (eq (car binding) var))) + ((for) + (find-if-subtree (lambda (x) (eq x var)) (cadr form))) ((progv) (and (consp (cadr form)) (eq (caadr form) 'quote) (consp (second (cadr form))) (member var (second (cadr form))))) + ((loop) + (loop for e on (cdr form) + thereis (and (eql (car e) 'for) (eql (cadr e) var)))) + ((mvb-if) + (find-in-tree var (second form))) (t nil)))) form)) @@ -2816,7 +3890,7 @@ (find-if-subtree pred (cdr tree)))) (t nil))) -(defun prune-flet (form try-fn) +(defun prune-flet (form try-fn top?) "Attempt to simplify a FLET form." (declare (type function try-fn)) @@ -2899,12 +3973,12 @@ (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))))))) + `(,@(butlast form) ,form2))) + top?)))) ;;; Routine to walk form, applying a function at each form ;;; The fn is applied in preorder. When it returns :stop, do @@ -2959,8 +4033,8 @@ (let* ((fn1 ',optimized-lambda-form) (fn2 ',unoptimized-lambda-form) (vals ',vals) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) + (v1 (apply (compile* fn1) vals)) + (v2 (apply (compile* fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) diff --git a/random/random-type-prop-tests-01.lsp b/random/random-type-prop-tests-01.lsp index da3a53e4..8c8a129e 100644 --- a/random/random-type-prop-tests-01.lsp +++ b/random/random-type-prop-tests-01.lsp @@ -13,6 +13,15 @@ (let ((type (make-random-type-containing x))) `(eql ,type)))) 2) +(def-type-prop-test typep.3 'typep + (list t #'(lambda (x) (declare (ignore x)) + (let ((type (make-random-type-containing + (make-random-element-of-type t)))) + `(eql ,type)))) + 2) +(def-type-prop-test typep.4 'typep + (list 'integer #'(lambda (x) (let ((type (make-random-type-containing 0))) `(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) @@ -26,13 +35,107 @@ (1 `(eql ,x)) (1 '(and t (not number) (not character)))))) 2) +(def-type-prop-test eq.2 'eq '(t (and (not number) (not character))) 2) +(def-type-prop-test eq.3 'eq '((and (not number) (not character)) t) 2) +(def-type-prop-test eq.4 '(lambda (x y) (if (eq x y) :a :b)) + (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 t)))) + 2) +(def-type-prop-test eq.5 '(lambda (x y) (if (eq x y) (if (eq y x) t))) + (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 t)))) + 2) +(def-type-prop-test eq.6 '(lambda (x y) (if (eq x y) (if (eq x y) :a :b) :c)) + (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 t)))) + 2) +(def-type-prop-test eq.7 '(lambda (x y z) (if (eq x y) (if (eq x z) :a :b) :c)) + (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 t))) + #'(lambda (x y) (rcase + (1 `(eql ,x)) + (1 `(eql ,y)) + (1 t)))) + 3) +(def-type-prop-test eq.8 '(lambda (x y z) (if (eq x y) :a (if (eq x z) :b :c))) + (list + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 t))) + #'(lambda (x y) (rcase + (1 `(eql ,x)) + (1 `(eql ,y)) + (1 t)))) + 3) (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 equal.3 '(lambda (x y) (if (equal x y) :a :b)) '(t t) 2) +(def-type-prop-test equal.4 '(lambda (x y) (if (equal x y) :a :b)) + (list t #'(lambda (x) `(eql ,x))) + 2) +(def-type-prop-test equal.5 '(lambda (x y z) + (if (equal x y) (if (equal x z) :a :b) :c)) + '(t t t) + 3) +(def-type-prop-test equal.6 '(lambda (x y z) + (if (equal x y) (if (equal x z) :a :b) :c)) + (list t + #'(lambda (x) `(or (eql ,x) t)) + #'(lambda (x y) `(eql ,(if (coin) x y)))) + 3) +(def-type-prop-test equal.7 '(lambda (x y z) + (if (equal x y) :a (if (equal x z) :b :c))) + '(t t t) + 3) +(def-type-prop-test equal.8 '(lambda (x y z) + (if (equal x y) :a (if (equal x z) :b :c))) + (list t + #'(lambda (x) `(or (eql ,x) t)) + #'(lambda (x y) `(member ,x ,y))) + 3) (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 equalp.3 '(lambda (x y) (if (equalp x y) :a :b)) '(t t) 2) +(def-type-prop-test equalp.4 '(lambda (x y) (if (equalp x y) :a :b)) + (list t #'(lambda (x) `(eql ,x))) + 2) +(def-type-prop-test equalp.5 '(lambda (x y z) + (if (equalp x y) (if (equalp x z) :a :b) :c)) + '(t t t) + 3) +(def-type-prop-test equalp.6 '(lambda (x y z) + (if (equalp x y) (if (equalp x z) :a :b) :c)) + (list t + #'(lambda (x) `(or (eql ,x) t)) + #'(lambda (x y) `(eql ,(if (coin) x y)))) + 3) +(def-type-prop-test equalp.7 '(lambda (x y z) + (if (equalp x y) :a (if (equalp x z) :b :c))) + '(t t t) + 3) +(def-type-prop-test equalp.8 '(lambda (x y z) + (if (equalp x y) :a (if (equalp x z) :b :c))) + (list t + #'(lambda (x) `(or (eql ,x) t)) + #'(lambda (x y) `(member ,x ,y))) + 3) +(def-type-prop-test identity.1 'identity '(t) 1) +(def-type-prop-test identity.2 'identity '(number) 1) (def-type-prop-test complement '(lambda (f y) (funcall (complement f) y)) (list `(eql ,#'symbolp) t) 2) (def-type-prop-test constantly @@ -50,6 +153,8 @@ '(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 if.7 '(lambda (x y) (if x y nil)) + (list 'boolean #'(lambda (x) x)) 2) (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) diff --git a/random/random-type-prop-tests-02.lsp b/random/random-type-prop-tests-02.lsp index 458aa8fc..bd25d5eb 100644 --- a/random/random-type-prop-tests-02.lsp +++ b/random/random-type-prop-tests-02.lsp @@ -78,6 +78,28 @@ (1 `(eql ,y))))) 3) +(def-type-prop-test comparisons.1 '(lambda (c x y) (funcall c x y)) + (list '(member = /= < > <= >=) + 'integer + #'(lambda (c x) + (declare (ignore c)) + (rcase (10 'integer) + (1 `(eql ,(1- x))) + (1 `(eql ,x)) + (1 `(eql ,(1+ x)))))) + 3) +(def-type-prop-test comparisons.2 '(lambda (c x y) (when (funcall c x y) (- x y))) + (list '(member = /= < > <= >=) + 'integer + #'(lambda (c x) + (declare (ignore c)) + (rcase (10 'integer) + (1 `(eql ,(1- x))) + (1 `(eql ,x)) + (1 `(eql ,(1+ x)))))) + 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) @@ -113,3 +135,17 @@ (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) + +(def-type-prop-test floor/first-value.1 '(lambda (x y) (values (floor x y))) '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test floor/first-value.2 '(lambda (x y) (values (floor x y))) '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test floor/first-value.3 '(lambda (x y) (values (floor x y))) '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test floor/second-value.1 '(lambda (x y) (nth-value 1 (floor x y))) '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test floor/second-value.2 '(lambda (x y) (nth-value 1 (floor x y))) '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test floor/second-value.3 '(lambda (x y) (nth-value 1 (floor x y))) '(real (and real (not (satisfies zerop)))) 2) + +(def-type-prop-test truncate/first-value.1 '(lambda (x y) (values (truncate x y))) '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test truncate/first-value.2 '(lambda (x y) (values (truncate x y))) '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test truncate/first-value.3 '(lambda (x y) (values (truncate x y))) '(real (and real (not (satisfies zerop)))) 2) +(def-type-prop-test truncate/second-value.1 '(lambda (x y) (nth-value 1 (truncate x y))) '(integer (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test truncate/second-value.2 '(lambda (x y) (nth-value 1 (truncate x y))) '(real (and integer (not (satisfies zerop)))) 2) +(def-type-prop-test truncate/second-value.3 '(lambda (x y) (nth-value 1 (truncate x y))) '(real (and real (not (satisfies zerop)))) 2) diff --git a/random/random-type-prop-tests-03.lsp b/random/random-type-prop-tests-03.lsp index a564c214..6db5eae4 100644 --- a/random/random-type-prop-tests-03.lsp +++ b/random/random-type-prop-tests-03.lsp @@ -36,10 +36,12 @@ (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) + :test #'(lambda (x y) (approx= x y (* 100 (epsilon x)))) :ignore 'arithmetic-error) +|# (def-type-prop-test 1+.1 '1+ '(integer) 1) (def-type-prop-test 1+.2 '1+ '(rational) 1) @@ -61,6 +63,16 @@ ;;; exp, expt here +(def-type-prop-test exp.1 'exp '((integer -100 100)) 1) +(def-type-prop-test exp.2 'exp '((real -100 100)) 1) +(def-type-prop-test exp.3 'exp '((complex (real -100 100))) 1) + +(def-type-prop-test expt.1 'expt '((integer 1 1000) (integer -1000 1000)) 2) +(def-type-prop-test expt.2 'expt '((integer -1000 -1) (integer -1000 1000)) 2) +(def-type-prop-test expt.3 'expt '((rational (0) 1000) (integer -1000 1000)) 2) +(def-type-prop-test expt.4 'expt '((real -1000 (0)) (real -100 100)) 2) +(def-type-prop-test expt.5 'expt '((real -1000 (0)) (eql 1/2)) 2) + (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) @@ -93,6 +105,8 @@ (def-type-prop-test complex.5 'complex '(real real) 2) (def-type-prop-test complexp 'complexp '(t) 1) +(def-type-prop-test complexp.2 '(lambda (x y) (complexp (complex x y))) + '(real real) 2) (def-type-prop-test conjugate 'conjugate '(number) 1) @@ -143,6 +157,30 @@ (def-type-prop-test lognot 'lognot '(integer) 1) +;; Combined integer tests +(def-type-prop-test logand.lognot.1 '(lambda (x y) (logand x (lognot y))) '(integer integer) 2) +(def-type-prop-test logand.lognot.2 '(lambda (x y) (logand (lognot x) y)) '(integer integer) 2) +(def-type-prop-test logand.lognot.3 '(lambda (x y) (logand (lognot x) (lognot y))) '(integer integer) 2) +(def-type-prop-test logand.lognot.4 '(lambda (x y) (lognot (logand x y))) '(integer integer) 2) + +(def-type-prop-test logior.lognot.1 '(lambda (x y) (logior x (lognot y))) '(integer integer) 2) +(def-type-prop-test logior.lognot.2 '(lambda (x y) (logior (lognot x) y)) '(integer integer) 2) +(def-type-prop-test logior.lognot.3 '(lambda (x y) (logior (lognot x) (lognot y))) '(integer integer) 2) +(def-type-prop-test logior.lognot.4 '(lambda (x y) (lognot (logior x y))) '(integer integer) 2) + +(def-type-prop-test logxor.lognot.1 '(lambda (x y) (logxor x (lognot y))) '(integer integer) 2) +(def-type-prop-test logxor.lognot.2 '(lambda (x y) (logxor (lognot x) y)) '(integer integer) 2) +(def-type-prop-test logxor.lognot.3 '(lambda (x y) (logxor (lognot x) (lognot y))) '(integer integer) 2) +(def-type-prop-test logxor.lognot.4 '(lambda (x y) (lognot (logxor x y))) '(integer integer) 2) + +(def-type-prop-test logand.logior.1 '(lambda (x y z) (logand x (logior y z))) '(integer integer integer) 3) +(def-type-prop-test logand.logior.2 '(lambda (x y z) (logand (logior x y) z)) '(integer integer integer) 3) +(def-type-prop-test logand.logior.3 '(lambda (x y z w) (logand (logior x y) (logior z w))) '(integer integer integer integer) 4) + +(def-type-prop-test logior.logand.1 '(lambda (x y z) (logior x (logand y z))) '(integer integer integer) 3) +(def-type-prop-test logior.logand.2 '(lambda (x y z) (logior (logand x y) z)) '(integer integer integer) 3) +(def-type-prop-test logior.logand.3 '(lambda (x y z w) (logior (logand x y) (logand z w))) '(integer integer integer integer) 4) + (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) @@ -183,4 +221,102 @@ `(integer 0 (,(length x))))) 3) +(def-type-prop-test parse-integer.3 'parse-integer + `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (satisfies has-nonzero-length)) + (eql :end) + ,#'(lambda (x &rest rest) (declare (ignore rest)) + `(integer 1 ,(length x)))) + 3) + +(def-type-prop-test parse-integer.4 'parse-integer + `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (satisfies has-nonzero-length)) + (eql :junk-allowed) + (member nil t)) + 3) + +(def-type-prop-test parse-integer.5 'parse-integer + `(string (eql :junk-allowed) (and t (not null))) + 3) + +(def-type-prop-test parse-integer.6 'parse-integer + `((and (vector (member #\0 #\1)) + (satisfies has-nonzero-length)) + (eql :radix) + (integer 2 36)) + 3) + +(def-type-prop-test parse-integer.7 'parse-integer + `((and (vector (member #\0 #\1 #\2 #\3)) + (satisfies has-nonzero-length)) + (eql :radix) + (integer 4 36)) + 3) + +(def-type-prop-test parse-integer.8 'parse-integer + `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5)) + (satisfies has-nonzero-length)) + (eql :radix) + (integer 6 36)) + 3) + +(def-type-prop-test parse-integer.9 'parse-integer + `((and (vector (member ,@(map 'list #'identity + "0123456789abcdefghijklmnopqrstuvwxyz"))) + (satisfies has-nonzero-length)) + (eql :radix) + (integer 36 36)) + 3) + (def-type-prop-test sxhash 'sxhash '(t) 1) +(def-type-prop-test sxhash.2 'sxhash '(string) 1) +(def-type-prop-test sxhash.3 '(lambda (s) (unless (= (sxhash s) (sxhash (map 'string #'identity s))) (error "Bad sxhash: ~a" s))) '(string) 1) + +(def-type-prop-test boole.1 'boole `(,(list 'member boole-1 boole-2 boole-andc1 + boole-andc2 boole-and boole-c1 boole-c2 + boole-clr boole-eqv boole-ior + boole-nand boole-nor boole-orc1 + boole-orc2 boole-set boole-xor) + integer integer) 3) + +;; (def-type-prop-test byte.1 'byte '((integer 0) (integer 0)) 2) +;; (def-type-prop-test byte.2 'byte '((integer 0 10) (integer 0)) 2) + +(def-type-prop-test byte.3 'byte '((integer 0 1000) (integer 0 1000)) 2) +(def-type-prop-test deposit-field.1 + '(lambda (m s p n) + (deposit-field m (byte s p) n)) + '(integer (integer 0 100) (integer 0 100) integer) + 4) +(def-type-prop-test dpb.1 + '(lambda (m s p n) + (dpb m (byte s p) n)) + '(integer (integer 0 100) (integer 0 100) integer) + 4) +(def-type-prop-test ldb.1 + '(lambda (s p n) + (ldb (byte s p) n)) + '((integer 0 100) (integer 0 100) integer) + 3) +(def-type-prop-test ldb.2 + '(lambda (s p n x) + (values (setf (ldb (byte s p) n) x) + n)) + '((integer 0 100) (integer 0 100) integer integer) + 4) +(def-type-prop-test ldb-test.1 + '(lambda (s p n) (ldb-test (byte s p) n)) + '((integer 0 100) (integer 0 100) integer) + 3) +(def-type-prop-test mask-field.1 + '(lambda (s p n) + (mask-field (byte s p) n)) + '((integer 0 100) (integer 0 100) integer) + 3) +(def-type-prop-test mask-field.2 + '(lambda (s p n x) + (values (setf (mask-field (byte s p) n) x) + n)) + '((integer 0 100) (integer 0 100) integer integer) + 4) diff --git a/random/random-type-prop-tests-04.lsp b/random/random-type-prop-tests-04.lsp index b12aae40..ff28eca3 100644 --- a/random/random-type-prop-tests-04.lsp +++ b/random/random-type-prop-tests-04.lsp @@ -101,7 +101,7 @@ (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 code-char 'code-char '((integer 0 (#.char-code-limit))) 1) (def-type-prop-test char-name 'char-name '(character) 1) (def-type-prop-test name-char 'name-char '(string) 1) diff --git a/random/random-type-prop-tests-05.lsp b/random/random-type-prop-tests-05.lsp index 5ef8ee93..90bcd5b4 100644 --- a/random/random-type-prop-tests-05.lsp +++ b/random/random-type-prop-tests-05.lsp @@ -6,6 +6,7 @@ (in-package :cl-test) (def-type-prop-test list.1 'list nil 1 :rest-type 't :maxargs 10) +(def-type-prop-test list.1a 'list nil 1 :rest-type 't :maxargs 20) (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) @@ -488,18 +489,18 @@ 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.1 'set-exclusive-or '(list list) 2 :test #'bag-equal) (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) + 4 :test #'bag-equal) (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) + 4 :test #'bag-equal) (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)) diff --git a/random/random-type-prop-tests-07.lsp b/random/random-type-prop-tests-07.lsp index efe6f59b..4c10f076 100644 --- a/random/random-type-prop-tests-07.lsp +++ b/random/random-type-prop-tests-07.lsp @@ -14,6 +14,10 @@ (def-type-prop-test string-downcase 'string-downcase '(string) 1) (def-type-prop-test string-capitalize 'string-capitalize '(string) 1) +(def-type-prop-test nstring-upcase 'nstring-upcase '(string) 1 :replicate '(t)) +(def-type-prop-test nstring-downcase 'nstring-downcase '(string) 1 :replicate '(t)) +(def-type-prop-test nstring-capitalize 'nstring-capitalize '(string) 1 :replicate '(t)) + (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) diff --git a/random/random-type-prop-tests-08.lsp b/random/random-type-prop-tests-08.lsp index 9f8c938c..7d891b93 100644 --- a/random/random-type-prop-tests-08.lsp +++ b/random/random-type-prop-tests-08.lsp @@ -58,6 +58,95 @@ ;;; make-sequence tests here +(def-type-prop-test make-sequence.1 'make-sequence + (list '(member list vector) '(integer 0 10)) + 2) + +(def-type-prop-test make-sequence.2 'make-sequence + (list '(member list vector) '(integer 0 10) + '(eql :initial-element) t) + 4) + +(def-type-prop-test make-sequence.3 'make-sequence + (list '(cons (eql vector) + (cons (cons (eql unsigned-byte) (cons (integer 1 64) null)) + null)) + '(integer 0 10)) + 2) + +(def-type-prop-test make-sequence.4 'make-sequence + (list '(cons (eql vector) + (cons (cons (eql unsigned-byte) (cons (integer 1 64) null)) + null)) + '(integer 0 10) + '(eql :initial-element) + #'(lambda (tp size k) (declare (ignore size k)) + (cadr tp))) + 4) + +(def-type-prop-test make-sequence.5 'make-sequence + (list '(cons (eql vector) + (cons (member base-char character) null)) '(integer 0 10)) + 2) + +(def-type-prop-test make-sequence.6 'make-sequence + (list '(cons (eql vector) (cons (member base-char character) null)) + '(integer 0 10) + '(eql :initial-element) + #'(lambda (tp size k) (declare (ignore size k)) (cadr tp))) + 4) + +(def-type-prop-test make-sequence.7 'make-sequence + (list '(eql simple-vector) + '(integer 0 10)) + 2) + +(def-type-prop-test make-sequence.8 'make-sequence + (list '(eql simple-vector) + '(integer 0 10) + '(eql :initial-element) + t) + 4) + +(def-type-prop-test make-sequence.9 'make-sequence + (list '(cons (eql simple-vector) (cons (integer 0 10) null)) + #'(lambda (tp) `(eql ,(cadr tp)))) + 2) + +(def-type-prop-test make-sequence.10 'make-sequence + (list '(cons (eql simple-vector) (cons (integer 0 10) null)) + #'(lambda (tp) `(eql ,(cadr tp))) + '(eql :initial-element) + t) + 4) + +(def-type-prop-test make-sequence.11 'make-sequence + (list '(cons (eql vector) (cons (member * t) (cons (integer 0 10) null))) + #'(lambda (tp) `(eql ,(caddr tp)))) + 2) + +(def-type-prop-test make-sequence.12 'make-sequence + (list '(cons (eql vector) (cons (member * t) (cons (integer 0 10) null))) + #'(lambda (tp) `(eql ,(caddr tp))) + '(eql :initial-element) + t) + 4) + +(def-type-prop-test make-sequence.13 'make-sequence + (list '(cons (eql vector) (cons (member base-char character) + (cons (integer 0 10) null))) + #'(lambda (tp) `(eql ,(caddr tp)))) + 2) + +(def-type-prop-test make-sequence.14 'make-sequence + (list '(cons (eql vector) (cons (member base-char character) + (cons (integer 0 10) null))) + #'(lambda (tp) `(eql ,(caddr tp))) + '(eql :initial-element) + #'(lambda (tp size k) (declare (ignore size k)) + `(eql ,(make-random-element-of-type (cadr tp))))) + 4) + (def-type-prop-test subseq.1 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) 2) @@ -67,6 +156,16 @@ #'(lambda (s start) `(integer ,start ,(length s)))) 3) +(def-type-prop-test length.subseq.1 '(lambda (s pos) (length (subseq s pos))) + (list 'sequence #'(lambda (s) `(integer 0 ,(length s)))) + 2) + +(def-type-prop-test length.subseq.2 '(lambda (s pos len) (length (subseq s pos len))) + (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 @@ -102,7 +201,7 @@ #'(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)))))))) + `(or ,@(loop for j from 1 to i collect `(vector (integer 0 ,(min (1- (ash 1 j)) (- (ash 1 i) 2))))))))) 3) @@ -197,6 +296,11 @@ (def-type-prop-test length.1 'length '(sequence) 1) +(def-type-prop-test length.2 '(lambda (s l) (<= (length s) l)) '(sequence integer) 2) +(def-type-prop-test length.3 '(lambda (s l) (< (length s) l)) '(sequence integer) 2) +(def-type-prop-test length.4 '(lambda (s l) (= (length s) l)) '(sequence integer) 2) +(def-type-prop-test length.5 '(lambda (s l) (> (length s) l)) '(sequence integer) 2) +(def-type-prop-test length.6 '(lambda (s l) (>= (length s) l)) '(sequence integer) 2) (def-type-prop-test reverse.1 'reverse '(sequence) 1) (def-type-prop-test nreverse.1 'nreverse '(sequence) 1 :replicate '(t)) diff --git a/random/random-type-prop-tests-09.lsp b/random/random-type-prop-tests-09.lsp index 46270c31..d71196a8 100644 --- a/random/random-type-prop-tests-09.lsp +++ b/random/random-type-prop-tests-09.lsp @@ -450,6 +450,22 @@ 'equal #'equal 'eql #'eql)) 6) +(def-type-prop-test position.11 'position + (list 'bit #'make-random-sequence-type-containing) + 2) + +(def-type-prop-test position.12 'position + (list 'symbol '(vector symbol)) + 2) + +(def-type-prop-test position.13 'position + (list 'base-char 'base-string) + 2) + +(def-type-prop-test position.14 'position + (list 'character 'string) + 2) + ;;; POSITION-IF (def-type-prop-test position-if.1 'position-if diff --git a/random/random-type-prop-tests-10.lsp b/random/random-type-prop-tests-10.lsp index 71d23474..cd375e67 100644 --- a/random/random-type-prop-tests-10.lsp +++ b/random/random-type-prop-tests-10.lsp @@ -112,3 +112,76 @@ (let ((len (length s2))) `(integer 0 ,len)))) 4) + +(def-type-prop-test search.13 '(lambda (seq1 seq2 s1 e1) + (search seq1 seq2 :start1 s1 :end1 e1)) + (list 'sequence 'sequence + #'(lambda (seq1 seq2) + (declare (ignore seq2)) + `(integer 0 ,(length seq1))) + #'(lambda (seq1 seq2 s1) + (declare (ignore seq2)) + `(or null (integer ,s1 ,(length seq1))))) + 4) + +(def-type-prop-test search.14 '(lambda (seq1 seq2 s1 e1 s2) + (search seq1 seq2 :start1 s1 :end1 e1 :start2 s2)) + (list 'sequence 'sequence + #'(lambda (seq1 seq2) + (declare (ignore seq2)) + `(integer 0 ,(length seq1))) + #'(lambda (seq1 seq2 s1) + (declare (ignore seq2)) + `(or null (integer ,s1 ,(length seq1)))) + #'(lambda (seq1 seq2 s1 e1) + (declare (ignore seq1 s1 e1)) + `(integer 0 ,(length seq2)))) + 5) + +(def-type-prop-test search.15 '(lambda (seq1 seq2 s1 e1 s2 e2) + (search seq1 seq2 :start1 s1 :end1 e1 :start2 s2 :end2 e2)) + (list 'sequence 'sequence + #'(lambda (seq1 seq2) + (declare (ignore seq2)) + `(integer 0 ,(length seq1))) + #'(lambda (seq1 seq2 s1) + (declare (ignore seq2)) + `(or null (integer ,s1 ,(length seq1)))) + #'(lambda (seq1 seq2 s1 e1) + (declare (ignore seq1 s1 e1)) + `(integer 0 ,(length seq2))) + #'(lambda (seq1 seq2 s1 e1 s2) + (declare (ignore seq1 s1 e1)) + `(or null (integer ,s2 ,(length seq2))))) + 6) + +(def-type-prop-test search.16 '(lambda (seq1 seq2 s1 s2 e2) + (search seq1 seq2 :start1 s1 :start2 s2 :end2 e2)) + (list 'sequence 'sequence + #'(lambda (seq1 seq2) + (declare (ignore seq2)) + `(integer 0 ,(length seq1))) + #'(lambda (seq1 seq2 s1) + (declare (ignore seq1 s1)) + `(integer 0 ,(length seq2))) + #'(lambda (seq1 seq2 s1 s2) + (declare (ignore seq1 s1)) + `(or null (integer ,s2 ,(length seq2))))) + 5) + +(def-type-prop-test search.17 '(lambda (seq1 seq2 e1 s2 e2) + (search seq1 seq2 :end1 e1 :start2 s2 :end2 e2)) + (list 'sequence 'sequence + #'(lambda (seq1 seq2) + (declare (ignore seq2)) + `(integer 0 ,(length seq1))) + #'(lambda (seq1 seq2 e1) + (declare (ignore seq1 e1)) + `(integer 0 ,(length seq2))) + #'(lambda (seq1 seq2 e1 s2) + (declare (ignore seq1 e1)) + `(or null (integer ,s2 ,(length seq2))))) + 5) + + + diff --git a/random/random-type-prop-tests-structs.lsp b/random/random-type-prop-tests-structs.lsp index 9a4423ad..f0e353e9 100644 --- a/random/random-type-prop-tests-structs.lsp +++ b/random/random-type-prop-tests-structs.lsp @@ -70,3 +70,17 @@ (def-type-prop-test structure-ref.2 'rtpt-2-a '(rtpt-2) 1) +;;; Structures with typed fields + +(defstruct rtpt-3 + (n 0 :type fixnum)) + +(defmethod make-random-element-of-type ((type (eql 'rtpt-3))) + (let ((n (make-random-element-of-type 'fixnum))) + (make-rtpt-3 :n n))) + +(defmethod replicate ((obj rtpt-3)) + (replicate-with (obj x (make-rtpt-3 :n (rtpt-3-n obj))))) + +(def-type-prop-test structure-ref.3 'rtpt-3-n '(rtpt-3) 1) +(def-type-prop-test structure-assign.3 '(lambda (obj x) (setf (rtpt-3-n obj) x) (values obj (rtpt-3-n obj))) '(rtpt-3 fixnum) 2) diff --git a/random/random-type-prop-tests.lsp b/random/random-type-prop-tests.lsp index 6f86d1c7..c7247b55 100644 --- a/random/random-type-prop-tests.lsp +++ b/random/random-type-prop-tests.lsp @@ -7,16 +7,8 @@ (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") +(loop for i from 1 to 17 + do (load (format nil "random/random-type-prop-tests-~2,vD.lsp" #\0 i))) -(load "random-type-prop-tests-structs.lsp") +(load "random/random-type-prop-tests-structs.lsp") diff --git a/random/random-type-prop.lsp b/random/random-type-prop.lsp index dfb195df..e57fb5fc 100644 --- a/random/random-type-prop.lsp +++ b/random/random-type-prop.lsp @@ -6,19 +6,101 @@ (in-package :cl-test) (eval-when (:compile-toplevel :load-toplevel) - (compile-and-load "ANSI-TESTS:AUX;random-aux.lsp") - (compile-and-load "random/random-int-form.lsp")) + ;; (compile-and-load "ANSI-TESTS:AUX;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 *param-types* *params* *is-var?* *form* *eval-form*)) (declaim (special *replicate-type*)) (defparameter *default-reps* 1000) +(defparameter *default-test-reps* 1) +(defparameter *default-enclosing-the* nil) (defparameter *default-cell* nil) -(defparameter *default-ignore* 'arithmetic-error) +(defparameter *default-ignore* '(or arithmetic-error internal-test-failure)) (defparameter *default-arg-the* t) +(defparameter *with-satisfies-eval* nil) ;; when true, can generate (satisfies eval) types in make-random-type-containing + +(defparameter *default-special-param-fn* #'(lambda (p v) (declare (ignore v)) p) + "Function called on parameter names to possibly enrich them before +using them as actual parameters to the function call") + +(defparameter *spfg* 0 "Dummy variable for SPECIAL-PARAM-FN1 code") + +(declaim (notinline my-identity)) +(defun my-identity (x) x) + +(defun special-param-fn1 (p v) + (if (coin) + p + (let ((tp (make-random-type-containing v))) + `(labels ((%f () (the ,tp ,p))) ;; (my-identity ,p)))) + (declare (dynamic-extent (function %f))) + (multiple-value-call #'%f (values)))))) + +(defparameter *spf1a-counter* 0) + +(defun special-param-fn1a (p v) + (if (eql (mod (incf *spf1a-counter*) 2) 0) + (if (coin) + p + (let ((tp (make-random-type-containing v))) + `(labels ((%f () (the ,tp ,p))) ;; (my-identity ,p)))) + (declare (dynamic-extent (function %f))) + (multiple-value-call #'%f (values))))) + p)) + +(defparameter *spf2* t) + +(defun special-param-fn2 (p v) + (if (coin) + p + (let* ((tp (make-random-type-containing v)) + (z (handler-case (make-random-element-of-type tp) + (error () nil)))) + (if (typep z tp) + `(flet ((%f (x) (the ,tp x))) + (if *spf2* (%f ,p) (%f ',z))) + p)))) + +(defun special-param-fn3 (p v) + (if (coin) + p + (let ((z (make-random-element-of-type (type-of v))) + (tp (make-random-type-containing v))) + (if (typep z (type-of p)) + `(flet ((%f (x) ,(if (coin) 'x `(the ,tp x)))) + (if *spf2* (%f ,p) (%f ',z))) + p)))) + +(defparameter *spf3* 0) + +(defun special-param-fn4 (p v) + (if (coin) + p + (let ((z1 (make-random-element-of-type (type-of v))) + (z2 (make-random-element-of-type (type-of v))) + (tp (make-random-type-containing v))) + (if (and (typep z1 (type-of p)) + (typep z2 (type-of p))) + `(flet ((%f (x) ,(if (coin) 'x `(the ,tp x)))) + (case *spf3* + (0 (%f ,p)) + (1 (%f ',z1)) + (t (%f ',z2)))) + p)))) + +(defun special-param-fn5 (p v) + (if (coin) + p + (let ((tp1 (make-random-type-containing v)) + (tp2 (make-random-type-containing v))) + `(labels ((%f () (the ,tp1 (the ,tp2 ,p)))) + (declare (dynamic-extent (function %f))) + (multiple-value-call #'%f (values)))))) ;;; ;;; The random type prop tester takes three required arguments: @@ -70,6 +152,11 @@ ;;; reps *default-reps* Number of repetitions to try before stopping. ;;; The default is controlled by a special variable that ;;; is initially 1000. +;;; test-reps *default-test-reps* +;;; Execute each test TEST-REPS times (default 1). +;;; This is intended to help track down failures due to +;;; insideous memory corruption that show up some time +;;; after the actual bad input. ;;; 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 @@ -94,16 +181,19 @@ (defun do-random-type-prop-tests (operator arg-types minargs &key + (special-param-fn *default-special-param-fn*) (maxargs minargs) (rest-type t) (reps *default-reps*) - (enclosing-the nil) + (test-reps *default-test-reps*) + (enclosing-the *default-enclosing-the*) (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)) + (assert (typep test-reps '(integer 1))) (prog1 (dotimes (i reps) again @@ -124,11 +214,9 @@ ; (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)) + (vals (mapcar #'(lambda (r v) (if r (replicate v) v)) replicate vals)) (is-var? (if (consp replicate) + ;; Do not directly include values that are to be replicated (progn (assert (= (length replicate) (length vals))) (loop for x in replicate collect (or x (coin)))) @@ -138,7 +226,8 @@ for p in param-names when x collect p)) (param-types (mapcar #'make-random-type-containing vals replicate)) - (*param-types* param-types) + (*param-types* (progn (finish-output *trace-output*) + param-types)) (type-decls (loop for x in is-var? for p in param-names for tp in param-types @@ -147,12 +236,15 @@ (rval (cl:handler-bind (#+sbcl (sb-ext::compiler-note #'muffle-warning) (warning #'muffle-warning)) - (let* ((vals (if replicate (mapcar #'replicate vals) vals)) + (let* ((vals (mapcar #'(lambda (r v) (if r (replicate v) v)) replicate vals)) (eval-form (cons operator (loop for v in vals collect `(quote ,v))))) ;; (print eval-form) (terpri) ;; (dotimes (i 100) (eval eval-form)) + (setf *eval-form* eval-form) + ;; (format t "Calling EVAL on ~s~%" eval-form) (eval eval-form)))) + ;; (_ (format t "EVAL returned ~s~%" rval)) (result-type (if (and enclosing-the (integerp rval)) (make-random-type-containing rval) t)) @@ -160,11 +252,12 @@ for v in vals for r in replicate for p in param-names + for p-arg = (if r p (funcall special-param-fn p v)) collect (if x (if (and arg-the (coin)) (let ((tp (make-random-type-containing v r))) - `(the ,tp ,p)) - p) + `(the ,tp ,p-arg)) + p-arg) (if (or (consp v) (and (symbolp v) (not (or (keywordp v) (member v '(nil t)))))) @@ -195,19 +288,36 @@ (*print-case* :downcase)) (print (list :form form :vals vals)))) (finish-output) - (let* ((param-vals (loop for x in is-var? + (let ((result nil)) + (loop repeat test-reps + do (when *print-random-type-prop-input* (princ #\.)) + do (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? + (warning #'muffle-warning) + (error + (lambda (e) + (declare (special *error-lambda*) + (ignore e)) + (setf *error-lambda* form)))) + ;; (format t "Compiling...") (finish-output) + (multiple-value-bind (fn warning-p failure-p) + (compile nil form) + (declare (ignore warning-p)) + ;; (format t "...done~%") (finish-output) + (when failure-p + (return + (setf *random-type-prop-result* + (list :form form + :compile-error t)))) + fn)))) + (setf 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)))) + (apply fn param-vals))))) (setq *random-type-prop-result* (list :upgraded-result-type upgraded-result-type :form form @@ -215,7 +325,9 @@ :result result :rval rval)) (unless (funcall test result rval) - (return *random-type-prop-result*)))) + (return *random-type-prop-result*)) + ;; (format t "p") (finish-output) + )) ;; #+allegro (excl::gc t) )))) @@ -245,7 +357,11 @@ 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*) +(defvar *replicate-type* nil + "When true, the type is for a parameter that will be replicated, so don't +generate types that depend on its object identity like EQL or MEMBER") + +(defun make-random-type-containing (type &optional (*replicate-type* *replicate-type*)) (declare (special *replicate-type*)) (make-random-type-containing* type)) @@ -254,9 +370,32 @@ use the value in MEMBER or EQL type specifiers.")) (declare (special *replicate-type*)) (rcase (1 t) + (1 (if (and *with-satisfies-eval* (not (or (symbolp val) + (listp val)))) + '(satisfies eval) + (throw 'fail nil))) (1 (if (consp val) 'cons 'atom)) (1 (if *replicate-type* (make-random-type-containing* val) `(eql ,val))) + (1 ; (when (or (listp val) (symbolp val)) (throw 'fail nil)) + (let* ((e (make-random-element-of-type t)) ;; '(and t (not list) (not symbol)))) + (t2 (make-random-type-containing e)) + (t1 (make-random-type-containing val))) + (rcase + (1 `(or ,t1 ,t2)) + (1 `(or ,t2 ,t1))))) + (1 (let* ((e1 (make-random-element-of-type t)) + (e2 (make-random-element-of-type t)) + (t1 (make-random-type-containing e1)) + (t2 (make-random-type-containing e2)) + (t3 (make-random-type-containing val)) + (t4 (make-random-type-containing val))) + (rcase + (1 `(and (or ,t1 ,t3) (or ,t2 ,t4))) + (1 `(and (or ,t1 ,t3) (or ,t4 ,t2))) + (1 `(and (or ,t3 ,t1) (or ,t2 ,t4))) + (1 `(and (or ,t3 ,t1) (or ,t4 ,t2)))))) + (1 (class-of val)) (1 (if *replicate-type* (make-random-type-containing* val) (let* ((n1 (random 4)) @@ -294,6 +433,11 @@ use the value in MEMBER or EQL type specifiers.")) (4 (let ((lo (abs (make-random-integer))) (hi (abs (make-random-integer)))) `(integer ,(- val lo) ,(+ val hi)))) + (1 (let ((len (max 1 (integer-length val))) + (r (min (random 80) (random 80)))) + (if (and (>= val 0) (coin)) + `(unsigned-byte ,(+ len r)) + `(signed-byte ,(+ len (max 1 r)))))) (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) (2 ((val character)) @@ -352,6 +496,8 @@ use the value in MEMBER or EQL type specifiers.")) `(,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) @@ -461,8 +607,7 @@ use the value in MEMBER or EQL type specifiers.")) ;;; Macro for defining random type prop tests (defmacro def-type-prop-test (name &body args) - `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." - (string name)) + `(deftest ,(intern (concatenate 'string "RTP." (string name)) (find-package :cl-test)) (do-random-type-prop-tests ,@args) nil)) @@ -482,8 +627,15 @@ use the value in MEMBER or EQL type specifiers.")) (1 `(simple-array ,element-type (,length))) (2 (make-list-type length 'null element-type)))) +(defvar *random-sequence-type* nil) + +(defvar *random-sequence-type-size* 10 + "(Exclusive) upper bound on size for randomly generated sequences.") + (defun make-random-sequence-type-containing (element &optional *replicate-type*) - (make-sequence-type (random 10) (make-random-type-containing* element))) + (setf *random-sequence-type* + (make-sequence-type (random *random-sequence-type-size*) + (make-random-type-containing* element)))) (defun same-set-p (set1 set2 &rest args &key key test test-not) (declare (ignorable key test test-not)) @@ -509,6 +661,28 @@ use the value in MEMBER or EQL type specifiers.")) (declare (ignore v1 other)) (let ((d (length v2))) `(integer 0 ,d))) +(defun start-type-for-v (v &rest other) + (let* ((d (length v)) + (end (or (cadr (member :end other)) d))) + `(integer 0 ,end))) + +(defun start-type-for-v1 (v1 v2 &rest other) + (declare (ignore v2)) + (let* ((d (length v1)) + (end1 (or (cadr (member :end1 other)) d))) + `(integer 0 ,end1))) + +(defun start-type-for-v2 (v1 v2 &rest other) + (declare (ignore v1)) + (let* ((d (length v2)) + (end2 (or (cadr (member :end2 other)) d))) + `(integer 0 ,end2))) + +(defun end-type-for-v (v &rest other) + (let ((d (length v)) + (start (or (cadr (member :start other)) 0))) + `(integer ,start ,d))) + (defun end-type-for-v1 (v1 v2 &rest other) (declare (ignore v2)) (let ((d (length v1)) @@ -521,6 +695,18 @@ use the value in MEMBER or EQL type specifiers.")) (start2 (or (cadr (member :start2 other)) 0))) `(integer ,start2 ,d))) +(defun start-end-type (v1 v2 &rest other) + ;; General case of the above + (assert other) + (let ((s (car (last other)))) + (apply + (ecase s + (:start1 #'start-type-for-v1) + (:start2 #'start-type-for-v2) + (:end1 #'end-type-for-v1) + (:end2 #'end-type-for-v2)) + v1 v2 other))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -662,3 +848,35 @@ use the value in MEMBER or EQL type specifiers.")) (defun equalp-and-eql-elements (s1 s2) (and (equalp s1 s2) (every #'eql s1 s2))) + +;;; Bag equality of lists +(defun bag-equal (b1 b2 &key (test #'eql)) + (and + (= (length b1) (length b2)) + (cond + ((or (member test '(eq eql equal equalp)) + (member test (mapcar #'symbol-function '(eq eql equal equalp)))) + (let ((tab (make-hash-table :test test))) + (dolist (x b1) (incf (gethash x tab 0))) + (dolist (x b2) (decf (gethash x tab 0))) + (maphash (lambda (k v) (declare (ignore k)) + (unless (eql v 0) + (return-from bag-equal nil))) + tab) + t)) + (t + ;; Cannot use hash tables + ;; Be quadratically slow + (setf b2 (copy-list b2)) + (loop for x in b1 + always (cond + ((funcall test x (car b2)) + (pop b2) + t) + (t + (loop for e on b2 + do (when (and (cdr e) + (funcall test x (cadr e))) + (setf (cdr e) (cddr e)) + (return t)) + finally (return nil))))))))) diff --git a/random/random-types.lsp b/random/random-types.lsp index fa9b061d..7f047312 100644 --- a/random/random-types.lsp +++ b/random/random-types.lsp @@ -5,12 +5,29 @@ (in-package :cl-test) -(compile-and-load "types-aux.lsp") -(compile-and-load "random-aux.lsp") -(compile-and-load "random-int-form.lsp") +;; (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-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-type (size) (if (<= size 1) (rcase @@ -30,6 +47,25 @@ (lo (min x y)) (hi (max x y))) `(integer ,lo ,hi))) + (1 ;; sequences and arrays + (rcase + (1 'sequence) + (1 'list) + (1 'array) + (1 (let ((tp (make-random-type 1))) + (if (coin 3) + `(and (array ,tp) (not simple-array)) + `(array ,tp)))) + (1 'simple-array) + (1 (let ((tp (make-random-type 1))) + `(simple-array ,tp))) + (1 (rcase + (1 'string) + (1 '(and string (not simple-string))) + (1 'simple-string) + (1 'base-string) + (1 '(and base-string (not simple-base-string))) + (1 'simple-base-string))))) (1 (make-random-real-type)) ;; (1 (make-random-complex-type)) ) @@ -43,23 +79,6 @@ ; (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))) @@ -74,7 +93,6 @@ (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)) @@ -162,6 +180,23 @@ (t (%f))))))) +(defun test-types (t1 t2) + "Return true if a bug in subtypep has been found related +to types T1 and T2." + (handler-case + (multiple-value-bind (sub success) + (subtypep t1 t2) + (when success + (if sub + (check-all-subtypep t1 t2) + (let ((nt1 `(not ,t1)) + (nt2 `(not ,t2))) + ;; Here, subtypep thinks t1 is not a subtype of t1, + ;; so confirm subtypep does not also think + ;; (not t2) is a subtype of (not t1) + (subtypep nt2 nt1))))) + (error (e) e))) + (defun test-random-types (n size) (loop for t1 = (make-random-type size) for t2 = (make-random-type size) @@ -176,8 +211,10 @@ (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 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)) @@ -187,16 +224,6 @@ 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))) @@ -273,10 +300,16 @@ (values)) (defun prune-type-pair (pair &optional (fn #'test-types)) + "PAIR is a list of two types, and FN is a function that, +when called on two types, returns T if the pair succeeds +at demonstrating some bug. Reduce the pair to a minimal +pair that still shows the bug." (declare (type function fn)) + (assert (typep pair '(cons t (cons t null)))) (let ((t1 (first pair)) (t2 (second pair)) changed) + (assert (funcall fn t1 t2)) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp) @@ -302,7 +335,8 @@ (defun test-type-triple (t1 t2 t3) ;; Returns non-nil if a problem is found - (catch 'problem + (handler-case + (catch 'problem ;; why (multiple-value-bind (sub1 success1) (subtypep t1 t2) (when success1 @@ -311,7 +345,8 @@ (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)))))))) + (subtypep t1 `(and ,t2 ,t3))))))) + (error (e) e))) (defun test-random-types3 (n size) (loop for t1 = (make-random-type (1+ (random size))) @@ -326,12 +361,14 @@ collect (list t1 t2 t3) finally (terpri))) -(defun prune-type-triple (pair &optional (fn #'test-type-triple)) +(defun prune-type-triple (triple &optional (fn #'test-type-triple)) (declare (type function fn)) - (let ((t1 (first pair)) - (t2 (second pair)) - (t3 (third pair)) + (assert (typep triple '(cons t (cons t (cons t null))))) + (let ((t1 (first triple)) + (t2 (second triple)) + (t3 (third triple)) changed) + (assert (funcall fn t1 t2 t3)) (loop do (flet ((%try2 (new-tp) (when (funcall fn t1 new-tp t3) @@ -353,7 +390,7 @@ (prune-type t1 #'%try1))) do (flet ((%try3 (new-tp) (when (funcall fn t1 t2 new-tp) - (print "Success in second loop") + (print "Success in third loop") (print new-tp) (setq t3 new-tp changed t) diff --git a/structures/structure-00.lsp b/structures/structure-00.lsp index b0b26ac0..1f393c0d 100644 --- a/structures/structure-00.lsp +++ b/structures/structure-00.lsp @@ -140,6 +140,11 @@ ;; structure definition and the tests. ;; +(declaim (ftype (function (t t) (values cons &optional)) + defstruct-with-tests-fun) + (ftype (function (t t &optional t) (values t t &optional)) + defstruct-maketemp)) + (defmacro defstruct-with-tests (name-and-options &body slot-descriptions-and-documentation) "Construct standardized tests for a defstruct, and also diff --git a/system-construction/compile-file.lsp b/system-construction/compile-file.lsp index 7a60efa6..1e6f972e 100644 --- a/system-construction/compile-file.lsp +++ b/system-construction/compile-file.lsp @@ -18,6 +18,7 @@ (compile-file-pathname file))) (actual-warnings-p nil) (actual-style-warnings-p nil)) + (declare (ignorable actual-style-warnings-p)) (when (probe-file target-pathname) (delete-file target-pathname)) (fmakunbound funname) diff --git a/universe.lsp b/universe.lsp index 4e6bbdc1..f9212ac7 100644 --- a/universe.lsp +++ b/universe.lsp @@ -42,7 +42,7 @@ (defparameter *condition-objects* (locally (declare (optimize safety)) (loop for tp in *condition-types* append - (handler-case (list (make-condition tp)) + (cl:handler-case (list (make-condition tp)) (error () nil))))) (defparameter *standard-package-names* @@ -51,7 +51,7 @@ (defparameter *package-objects* (locally (declare (optimize safety)) (loop for pname in *standard-package-names* append - (handler-case (let ((pkg (find-package pname))) + (cl:handler-case (let ((pkg (find-package pname))) (and pkg (list pkg))) (error () nil))))) @@ -160,7 +160,7 @@ (declare (optimize safety)) (loop for name in namelist append - (handler-case + (cl:handler-case (list (read-from-string (concatenate 'string "\#\\" name))) (error () nil)))) @@ -357,7 +357,7 @@ ;; The ever-popular NIL array (locally (declare (optimize safety)) - (handler-case + (cl:handler-case (list (make-array '(0) :element-type nil)) (error () nil))) -- GitLab