diff --git a/ansi-tests/TODO b/ansi-tests/TODO index cbd9438dec423b7e762c3d7cab5346e3b0249eaa..b87e5b2f54cabedbd74d2f80b44b273f890688f0 100644 --- a/ansi-tests/TODO +++ b/ansi-tests/TODO @@ -110,4 +110,8 @@ Got: 0 44. Add tests for SPECIAL declarations in MACROLET (requested by piso on #lisp) (partially done) -45. Sweep files for missing order-of-execution tests \ No newline at end of file +45. Sweep files for missing order-of-execution tests + +46. Add tests that class objects are valid class specifiers in method definitions. + +47. Test that :import-from in DEFPACKAGE can take a package object. diff --git a/ansi-tests/misc.lsp b/ansi-tests/misc.lsp index be99775b6d385e1fff2eb70d7ea6d147d0b61c30..b3e032db73199d1a7fd2740f9a3e72dc24a6a33e 100644 --- a/ansi-tests/misc.lsp +++ b/ansi-tests/misc.lsp @@ -11061,3 +11061,18 @@ Broken at C::WT-MAKE-CLOSURE. (min -63 (rem 0 (min -67 0))))))))) 0) + +;;; sbcl 0.9.9.8, x86 linux +;;; TYPE-ERROR: The value 17549.955 is not of type REAL. + +(deftest misc.622 + (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) + (type real p2)) + (+ 81535869 (the (member 17549.955 #:g35917) p2)))) + 17549.955) + #.(+ 81535869 17549.955)) + diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index 831ba156c1aec4a842d7da46566de75764274201..1056915a6805d65bdee7fdc78a36d8d21e13cc4c 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -42,6 +42,26 @@ collect `((< ,r ,cw) ,@(cdr case))) (t ,@(cdar (last cases))))))) +(defmacro rselect (cumulative-frequency-array &rest cases) + (let ((len (length cases)) + (a (gensym "A")) + (max (gensym "MAX")) + (r (gensym "R")) + (p (gensym "P")) + (done (gensym "DONE"))) + (assert (> len 0)) + `(let ((,a ,cumulative-frequency-array)) + (assert (eql ,len (length ,a))) + (let* ((,max (aref ,a ,(1- len))) + (,r (random ,max))) + (block ,done + ,@(loop for i from 0 + for c in cases + collect + `(let ((,p (aref ,a ,i))) + (when (< ,r ,p) (return-from ,done ,c)))) + (error "Should not happen!")))))) + (defun make-random-integer-range (&optional var) "Generate a list (LO HI) of integers, LO <= HI. This is used for generating integer types." diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index 8e7eedfb21b86bda49316f58f0e3c09464c2b64c..642b97969f7b6b3a5f8acd320046ce5883376a15 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -41,8 +41,9 @@ ;;; (declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals* - *opt-result* *unopt-result* $x $y $z - *compile-unoptimized-form*)) + *opt-result* *unopt-result* $x $y $z + *compile-unoptimized-form* + *make-random-integer-form-cdf*)) ;;; Little functions used to run collected tests. ;;; (f i) runs the ith collected optimized test @@ -50,22 +51,22 @@ ;;; (p i) prints the ith test (forms, input values, and other information) (defun f (i) (let ((plist (elt $y i))) - (apply (compile nil (getf plist :optimized-lambda-form)) - (getf plist :vals)))) + (apply (compile nil (getf plist :optimized-lambda-form)) + (getf plist :vals)))) (defun g (i) (let ((plist (elt $y i))) - (if *compile-unoptimized-form* - (apply (compile nil (getf plist :unoptimized-lambda-form)) - (getf plist :vals)) - (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) - (getf plist :vals))))) + (if *compile-unoptimized-form* + (apply (compile nil (getf plist :unoptimized-lambda-form)) + (getf plist :vals)) + (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form)))) + (getf plist :vals))))) (defun p (i) (write (elt $y i) :pretty t :escape t) (values)) (defun load-failures (&key (pathname "failures.lsp")) (length (setq $y (with-open-file (s pathname :direction :input) - (loop for x = (read s nil) - while x collect x))))) + (loop for x = (read s nil) + while x collect x))))) (defun tn (n &optional (size 100)) (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n)))))) @@ -83,6 +84,40 @@ (defmacro cl-handler-case (&rest args) `(cl:handler-case ,@args)) +(eval-when + (:compile-toplevel :load-toplevel :execute) + (defun cumulate (vec) + (loop for i from 1 below (length vec) + do (incf (aref vec i) (aref vec (1- i)))) + vec)) + +(defparameter *default-make-random-integer-form-cdf* + (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1 + #-allegro 5 5 5 #-(or gcl ecl armedbear) 2 + 2 #-(or cmu allegro poplog) 5 4 30 + 4 20 3 2 2 1 1 5 30 #-poplog 5 + #-(or allegro poplog) 10 + 50 4 4 10 20 10 10 3 + 20 5 #-(or armedbear) 20 + 2 2 2)))) + +(defparameter *make-random-integer-form-cdf* + (copy-seq *default-make-random-integer-form-cdf*)) + +(eval-when + (:compile-toplevel :load-toplevel :execute) + (defmacro with-random-integer-form-params (&body forms) + (let ((len (gensym "LEN")) + (vec (gensym "VEC"))) + `(let* ((,len (length *default-make-random-integer-form-cdf*)) + (,vec (make-array ,len))) + (loop for i from 0 below ,len do (setf (aref ,vec i) + (1+ (min (random 100) + (random 100))))) + (setq ,vec (cumulate ,vec)) + (let ((*make-random-integer-form-cdf* ,vec)) + ,@forms))))) + ;;; Run the random tester, collecting failures into the special ;;; variable $y. @@ -95,8 +130,8 @@ (format t "~6D | " i) (finish-output *standard-output*) (let ((x (test-random-integer-forms - size nvars *loop-random-int-form-period* - :index (* (1- i) *loop-random-int-form-period*)))) + size nvars *loop-random-int-form-period* + :index (* (1- i) *loop-random-int-form-period*)))) (when x (setq $x (append $x x)) (setq x (prune-results x)) @@ -127,12 +162,12 @@ (defun test-random-integer-forms (size nvars n - &key ((:random-state *random-state*) (make-random-state t)) - (file-prefix "b") - (index 0) - (random-size nil) - (random-nvars nil) - ) + &key ((:random-state *random-state*) (make-random-state t)) + (file-prefix "b") + (index 0) + (random-size nil) + (random-nvars nil) + ) "Generate random integer forms of size SIZE with NVARS variables. Do this N times, returning all those on which a discrepancy @@ -143,69 +178,66 @@ (assert (and (integerp n) (plusp n))) (assert (and (integerp n) (plusp size))) -;;; #+sbcl -;;; (loop for x in (reverse sb-ext:*before-gc-hooks*) -;;; do (pushnew x sb-ext:*after-gc-hooks*)) - (loop for i from 1 to n - do (when (= (mod i 100) 0) - ;; #+sbcl (print "Do gc...") - ;; #+sbcl (sb-ext::gc :full t) - ;; #+lispworks-personal-edition (cl-user::normal-gc) - (prin1 i) (princ " ") (finish-output *standard-output*)) - nconc (let ((result (test-random-integer-form - (if random-size (1+ (random size)) size) - (if random-nvars (1+ (random nvars)) nvars) - :index (+ index i) - :file-prefix file-prefix))) - (when result - (let ((*print-readably* nil)) - (format t "~%~A~%" (format nil "~S" (car result))) - (finish-output *standard-output*))) - result))) + do (when (= (mod i 100) 0) + ;; #+sbcl (print "Do gc...") + ;; #+sbcl (sb-ext::gc :full t) + ;; #+lispworks-personal-edition (cl-user::normal-gc) + (prin1 i) (princ " ") (finish-output *standard-output*)) + nconc (let ((result (test-random-integer-form + (if random-size (1+ (random size)) size) + (if random-nvars (1+ (random nvars)) nvars) + :index (+ index i) + :file-prefix file-prefix))) + (when result + (let ((*print-readably* nil)) + (format t "~%~A~%" (format nil "~S" (car result))) + (finish-output *standard-output*))) + result))) (defun test-random-integer-form (size nvars &key (index 0) (file-prefix "b")) (let* ((vars (subseq '(a b c d e f g h i j k l m - n o p q r s u v w x y z) 0 nvars)) - (var-ranges (mapcar #'make-random-integer-range vars)) - (var-types (mapcar #'(lambda (range) - (let ((lo (car range)) - (hi (cadr range))) - (assert (>= hi lo)) - `(integer ,lo ,hi))) - var-ranges)) - (form (let ((*vars* (loop for v in vars - for tp in var-types - collect (make-var-desc :name v - :type tp))) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil) - (*go-tags* nil) - ) - (make-random-integer-form (1+ (random size))))) - (vals-list - (loop repeat *random-vals-list-bound* - collect - (mapcar #'(lambda (range) - (let ((lo (car range)) - (hi (cadr range))) - (random-from-interval (1+ hi) lo))) - var-ranges))) - (opt-decls-1 (make-random-optimize-settings)) - (opt-decls-2 (make-random-optimize-settings))) + n o p q r s u v w x y z) 0 nvars)) + (var-ranges (mapcar #'make-random-integer-range vars)) + (var-types (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (assert (>= hi lo)) + `(integer ,lo ,hi))) + var-ranges)) + (form (let ((*vars* (loop for v in vars + for tp in var-types + collect (make-var-desc :name v + :type tp))) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil) + ) + (with-random-integer-form-params + (make-random-integer-form (1+ (random size)))))) + (vals-list + (loop repeat *random-vals-list-bound* + collect + (mapcar #'(lambda (range) + (let ((lo (car range)) + (hi (cadr range))) + (random-from-interval (1+ hi) lo))) + var-ranges))) + (opt-decls-1 (make-random-optimize-settings)) + (opt-decls-2 (make-random-optimize-settings))) (when *print-immediately* (with-open-file (s (format nil "~A~A.lsp" file-prefix index) - :direction :output :if-exists :error) + :direction :output :if-exists :error) (print `(defparameter *x* - '(:vars ,vars - :var-types ,var-types - :vals-list ,vals-list - :decls1 ,opt-decls-1 - :decls2 ,opt-decls-2 - :form ,form)) - s) + '(:vars ,vars + :var-types ,var-types + :vals-list ,vals-list + :decls1 ,opt-decls-1 + :decls2 ,opt-decls-2 + :form ,form)) + s) (print '(load "c.lsp") s) (finish-output s)) ;; (cl-user::gc) @@ -215,15 +247,15 @@ (defun make-random-optimize-settings () (loop for settings = (list* - (list 'speed (random 4)) - #+sbcl '(sb-c:insert-step-conditions 0) - (loop for s in '(space safety debug compilation-speed) - for n = (random 4) - collect (list s n))) - while - #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) - #-allegro nil - finally (return (random-permute settings)))) + (list 'speed (random 4)) + #+sbcl '(sb-c:insert-step-conditions 0) + (loop for s in '(space safety debug compilation-speed) + for n = (random 4) + collect (list s n))) + while + #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal) + #-allegro nil + finally (return (random-permute settings)))) (defun fn-symbols-in-form (form) "Return a list of the distinct standardized lisp function @@ -236,14 +268,14 @@ (defun fn-symbols-in-form* (form) (when (consp form) (if (symbolp (car form)) - (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) + (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form))) (mapcan #'fn-symbols-in-form* form)))) (defun fn-arg-name (fn-name arg-index) (intern (concatenate 'string - (subseq (symbol-name fn-name) 1) - (format nil "-~D" arg-index)) - (symbol-package fn-name))) + (subseq (symbol-name fn-name) 1) + (format nil "-~D" arg-index)) + (symbol-package fn-name))) (declaim (special *flet-names*)) (defparameter *flet-names* nil) @@ -253,9 +285,9 @@ (defun random-var-desc () (loop (let* ((pos (random (length *vars*))) - (desc (elt *vars* pos))) + (desc (elt *vars* pos))) (when (= pos (position (var-desc-name desc) (the list *vars*) - :key #'var-desc-name)) + :key #'var-desc-name)) (return desc))))) (defun is-zero-rank-integer-array-type (type) @@ -265,309 +297,281 @@ (eq (car type) 'array) (cddr type) (or (eq (cadr type) '*) - (subtypep (cadr type) 'integer)) + (subtypep (cadr type) 'integer)) (or (eql (caddr type) 0) - (null (caddr type))))) + (null (caddr type))))) (defun make-random-integer-form (size) "Generate a random legal lisp form of size SIZE (roughly)." - + (if (<= size 1) ;; Leaf node -- generate a variable, constant, or flet function call (loop when (rcase - (10 (make-random-integer)) - (9 (if *vars* - (let* ((desc (random-var-desc)) - (type (var-desc-type desc)) - (name (var-desc-name desc))) - (cond - ((subtypep type 'integer) name) - (; (subtypep type '(array integer 0)) - (is-zero-rank-integer-array-type type) - `(aref ,name)) - ((subtypep type '(cons integer integer)) - (rcase (1 `(car ,name)) - (1 `(cdr ,name)))) - (t nil))) - nil)) - (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) - (2 (if *flet-names* - (let* ((flet-entry (random-from-seq *flet-names*)) - (flet-name (car flet-entry)) - (flet-minargs (cadr flet-entry)) - (flet-maxargs (caddr flet-entry)) - (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) - (args (loop repeat nargs - collect (make-random-integer-form 1)))) - `(,flet-name ,@args)) - nil))) + (10 (make-random-integer)) + (9 (if *vars* + (let* ((desc (random-var-desc)) + (type (var-desc-type desc)) + (name (var-desc-name desc))) + (cond + ((subtypep type 'integer) name) + (; (subtypep type '(array integer 0)) + (is-zero-rank-integer-array-type type) + `(aref ,name)) + ((subtypep type '(cons integer integer)) + (rcase (1 `(car ,name)) + (1 `(cdr ,name)))) + (t nil))) + nil)) + (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil)) + (2 (if *flet-names* + (let* ((flet-entry (random-from-seq *flet-names*)) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + (args (loop repeat nargs + collect (make-random-integer-form 1)))) + `(,flet-name ,@args)) + nil))) return it) ;; (> size 1) - (rcase + (rselect *make-random-integer-form-cdf* ;; flet call - ;; #-(or armedbear) - (10 - (make-random-integer-flet-call-form size)) - - (5 (make-random-aref-form size)) - + (make-random-integer-flet-call-form size) + (make-random-aref-form size) ;; Unary ops - (40 - (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate - rational rationalize - numerator denominator - identity progn floor - ;; #-(or armedbear) - ignore-errors - cl:handler-case - restart-case - ceiling truncate round realpart imagpart - integer-length logcount values - locally)))) - `(,op ,(make-random-integer-form (1- size))))) - - (4 - (make-random-integer-unwind-protect-form size)) - - (5 (make-random-integer-mapping-form size)) + (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate + rational rationalize + numerator denominator + identity progn floor + ;; #-(or armedbear) + ignore-errors + cl:handler-case + restart-case + ceiling truncate round realpart imagpart + integer-length logcount values + locally)))) + `(,op ,(make-random-integer-form (1- size)))) + + (make-random-integer-unwind-protect-form size) + (make-random-integer-mapping-form size) ;; prog1, multiple-value-prog1 - (4 - (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))) + (let* ((op (random-from-seq #(prog1 multiple-value-prog1))) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args)) ;; prog2 - (2 (let* ((nforms (random 4)) - (sizes (random-partition (1- size) (+ nforms 2))) - (args (mapcar #'make-random-integer-form sizes))) - `(prog2 ,@args))) + (let* ((nforms (random 4)) + (sizes (random-partition (1- size) (+ nforms 2))) + (args (mapcar #'make-random-integer-form sizes))) + `(prog2 ,@args)) - (2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) + `(isqrt (abs ,(make-random-integer-form (- size 2)))) - (10 `(the integer ,(make-random-integer-form (1- size)))) + `(the integer ,(make-random-integer-form (1- size))) - (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) - (1 `(restart-bind nil ,(make-random-integer-form (1- size)))) + `(cl:handler-bind nil ,(make-random-integer-form (1- size))) + `(restart-bind nil ,(make-random-integer-form (1- size))) #-armedbear - (1 `(macrolet () ,(make-random-integer-form (1- size)))) + `(macrolet () ,(make-random-integer-form (1- size))) #-armedbear - (1 `(symbol-macrolet () ,(make-random-integer-form (1- size)))) + `(symbol-macrolet () ,(make-random-integer-form (1- size))) ;; dotimes #-allegro - (5 - (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) - (count (random 4)) - (sizes (random-partition (1- size) 2)) - (body (let ((*vars* (cons (make-var-desc :name var :type nil) - *vars*))) - (make-random-integer-form (first sizes)))) - (ret-form (make-random-integer-form (second sizes)))) - (unless (consp body) (setq body `(progn ,body))) - `(dotimes (,var ,count ,ret-form) ,body))) + (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4))) + (count (random 4)) + (sizes (random-partition (1- size) 2)) + (body (let ((*vars* (cons (make-var-desc :name var :type nil) + *vars*))) + (make-random-integer-form (first sizes)))) + (ret-form (make-random-integer-form (second sizes)))) + (unless (consp body) (setq body `(progn ,body))) + `(dotimes (,var ,count ,ret-form) ,body)) ;; loop - (5 (make-random-loop-form (1- size))) + (make-random-loop-form (1- size)) - (5 (make-random-count-form size)) + (make-random-count-form size) #-(or gcl ecl armedbear) ;; load-time-value - (2 - (let ((arg (let ((*flet-names* nil) - (*vars* nil) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil) - (*go-tags* nil)) - (make-random-integer-form (1- size))))) - (rcase - (4 `(load-time-value ,arg t)) - (2 `(load-time-value ,arg)) - (2 `(load-time-value ,arg nil))))) + (let ((arg (let ((*flet-names* nil) + (*vars* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil) + (*go-tags* nil)) + (make-random-integer-form (1- size))))) + (rcase + (4 `(load-time-value ,arg t)) + (2 `(load-time-value ,arg)) + (2 `(load-time-value ,arg nil)))) ;; eval - (2 (make-random-integer-eval-form size)) + (make-random-integer-eval-form size) #-(or cmu allegro poplog) - (20 - (destructuring-bind (s1 s2) - (random-partition (- size 2) 2) - `(ash ,(make-random-integer-form s1) - (min ,(random 100) - ,(make-random-integer-form s2))))) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(ash ,(make-random-integer-form s1) + (min ,(random 100) + ,(make-random-integer-form s2)))) ;; binary floor, ceiling, truncate, round - (4 - (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) - (op2 (random-from-seq #(max min)))) - (destructuring-bind (s1 s2) - (random-partition (- size 2) 2) - `(,op ,(make-random-integer-form s1) - (,op2 ,(if (eq op2 'max) - (1+ (random 100)) - (- (1+ (random 100)))) - ,(make-random-integer-form s2)))))) - + (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) + (op2 (random-from-seq #(max min)))) + (destructuring-bind (s1 s2) + (random-partition (- size 2) 2) + `(,op ,(make-random-integer-form s1) + (,op2 ,(if (eq op2 'max) + (1+ (random 100)) + (- (1+ (random 100)))) + ,(make-random-integer-form s2))))) + ;; Binary op - (30 (let* ((op (random-from-seq - '(+ - * logand min max gcd - lcm - #-:allegro - logandc1 - logandc2 logeqv logior lognand lognor - #-:allegro - logorc1 - logorc2 - logxor - )))) - (destructuring-bind (leftsize rightsize) - (random-partition (1- size) 2) - (let ((e1 (make-random-integer-form leftsize)) - (e2 (make-random-integer-form rightsize))) - `(,op ,e1 ,e2))))) + '(+ - * logand min max gcd + lcm + #-:allegro + logandc1 + logandc2 logeqv logior lognand lognor + #-:allegro + logorc1 + logorc2 + logxor + )))) + (destructuring-bind (leftsize rightsize) + (random-partition (1- size) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(,op ,e1 ,e2)))) ;; boole - (4 - (let* ((op (random-from-seq - #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand - boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) - (destructuring-bind (leftsize rightsize) - (random-partition (- size 2) 2) - (let ((e1 (make-random-integer-form leftsize)) - (e2 (make-random-integer-form rightsize))) - `(boole ,op ,e1 ,e2))))) + (let* ((op (random-from-seq + #(boole-1 boole-2 boole-and boole-andc1 boole-andc2 + boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand + boole-nor boole-orc1 boole-orc2 boole-set boole-xor)))) + (destructuring-bind (leftsize rightsize) + (random-partition (- size 2) 2) + (let ((e1 (make-random-integer-form leftsize)) + (e2 (make-random-integer-form rightsize))) + `(boole ,op ,e1 ,e2)))) ;; n-ary ops - (20 - (let* ((op (random-from-seq #(+ - * logand min max - logior values lcm gcd logxor))) - (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40))))) - (nargs (1+ (min (random nmax) (random nmax)))) - (sizes (random-partition (1- size) nargs)) - (args (mapcar #'make-random-integer-form sizes))) - `(,op ,@args))) + (let* ((op (random-from-seq #(+ - * logand min max + logior values lcm gcd logxor))) + (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40))))) + (nargs (1+ (min (random nmax) (random nmax)))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(,op ,@args)) ;; expt - (3 `(expt ,(make-random-integer-form (1- size)) ,(random 3))) + `(expt ,(make-random-integer-form (1- size)) ,(random 3)) ;; coerce - (2 `(coerce ,(make-random-integer-form (1- size)) 'integer)) + `(coerce ,(make-random-integer-form (1- size)) 'integer) ;; complex (degenerate case) - (2 `(complex ,(make-random-integer-form (1- size)) 0)) + `(complex ,(make-random-integer-form (1- size)) 0) ;; quotient (degenerate cases) - (1 `(/ ,(make-random-integer-form (1- size)) 1)) - (1 `(/ ,(make-random-integer-form (1- size)) -1)) + `(/ ,(make-random-integer-form (1- size)) 1) + `(/ ,(make-random-integer-form (1- size)) -1) ;; tagbody - (5 (make-random-tagbody-and-progn size)) + (make-random-tagbody-and-progn size) ;; conditionals - (60 - (let* ((cond-size (random (max 1 (floor size 2)))) - (then-size (random (- size cond-size))) - (else-size (- size 1 cond-size then-size)) - (pred (make-random-pred-form cond-size)) - (then-part (make-random-integer-form then-size)) - (else-part (make-random-integer-form else-size))) - `(if ,pred ,then-part ,else-part))) + (let* ((cond-size (random (max 1 (floor size 2)))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-integer-form then-size)) + (else-part (make-random-integer-form else-size))) + `(if ,pred ,then-part ,else-part)) #-poplog - (5 (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)))) + `(,(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) - (10 (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)))) + `(,(random-from-seq '(ldb mask-field)) + ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2))) - (50 (make-random-integer-binding-form size)) + (make-random-integer-binding-form size) ;; progv - #-(or ecl) - (4 (make-random-integer-progv-form size)) + (make-random-integer-progv-form size) - (4 `(let () ,(make-random-integer-form (1- size)))) + `(let () ,(make-random-integer-form (1- size))) - (10 (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))))) + (*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) + `(block ,name ,(make-random-integer-form (1- size)))) - (20 (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))))) + (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) + `(catch ,tag ,(make-random-integer-form (1- size)))) - (10 ;; setq and similar - (make-random-integer-setq-form size)) + ;; setq and similar + (make-random-integer-setq-form size) - (10 (make-random-integer-case-form size)) + (make-random-integer-case-form size) - (3 (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))) + (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)) - (20 (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))) + (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)) - (5 (if *random-int-form-blocks* - (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) - (let ((name (random-from-seq *random-int-form-blocks*)) - (pred (make-random-pred-form s1)) - (then (make-random-integer-form s2)) - (else (make-random-integer-form s3))) - `(if ,pred (return-from ,name ,then) ,else))) - ;; No blocks -- try again - (make-random-integer-form size))) + (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3) + (let ((name (random-from-seq *random-int-form-blocks*)) + (pred (make-random-pred-form s1)) + (then (make-random-integer-form s2)) + (else (make-random-integer-form s3))) + `(if ,pred (return-from ,name ,then) ,else))) + ;; No blocks -- try again + (make-random-integer-form size)) #-(or armedbear) - (20 - (make-random-flet-form size)) + (make-random-flet-form size) - (2 (let* ((nbits (1+ (min (random 20) (random 20)))) - (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) - (op (random-from-seq #(bit sbit)))) - `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))) + (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector)) + (op (random-from-seq #(bit sbit)))) + `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits)))))) - (2 (let* ((nvals (1+ (min (random 20) (random 20)))) - (lim (ash 1 (+ 3 (random 40)))) - (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) - (op (random-from-seq #(aref svref elt)))) - `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) + (lim (ash 1 (+ 3 (random 40)))) + (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector)) + (op (random-from-seq #(aref svref elt)))) + `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) - (2 (let* ((nvals (1+ (min (random 20) (random 20)))) - (lim (ash 1 (+ 3 (random 40)))) - (vals (loop repeat nvals collect (random lim))) - (op 'elt)) - `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))) + (lim (ash 1 (+ 3 (random 40)))) + (vals (loop repeat nvals collect (random lim))) + (op 'elt)) + `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals)))))) ))) @@ -575,98 +579,98 @@ (or (when *vars* (let* ((desc (random-var-desc)) - (type (var-desc-type desc)) - (name (var-desc-name desc))) + (type (var-desc-type desc)) + (name (var-desc-name desc))) (cond - ((null type) nil) - ((subtypep type '(array integer (*))) - `(aref ,name (min ,(1- (first (third type))) - (max 0 ,(make-random-integer-form (- size 2)))))) - ((subtypep type '(array integer (* *))) - (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) - `(aref ,name - (min ,(1- (first (third type))) - (max 0 ,(make-random-integer-form s1))) - (min ,(1- (second (third type))) - (max 0 ,(make-random-integer-form s2)))))) - (t nil)))) + ((null type) nil) + ((subtypep type '(array integer (*))) + `(aref ,name (min ,(1- (first (third type))) + (max 0 ,(make-random-integer-form (- size 2)))))) + ((subtypep type '(array integer (* *))) + (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) + `(aref ,name + (min ,(1- (first (third type))) + (max 0 ,(make-random-integer-form s1))) + (min ,(1- (second (third type))) + (max 0 ,(make-random-integer-form s2)))))) + (t nil)))) (make-random-integer-form size))) (defun make-random-count-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let ((arg1 (make-random-integer-form s1)) - (arg2-args (loop repeat s2 collect (make-random-integer)))) + (arg2-args (loop repeat s2 collect (make-random-integer)))) (let ((op 'count) - (test (random-from-seq #(eql = /= < > <= >=))) - (arg2 (rcase - (1 (make-array (list s2) :initial-contents arg2-args)) - (1 - (let* ((mask (1- (ash 1 (1+ (random 32)))))) - (make-array (list s2) - :initial-contents - (mapcar #'(lambda (x) (logand x mask)) arg2-args) - :element-type `(integer 0 ,mask)))) - (1 `(quote ,arg2-args))))) - `(,op ,arg1 ,arg2 ,@(rcase - (2 nil) - (1 (list :test `(quote ,test))) - (1 (list :test-not `(quote ,test))))))))) + (test (random-from-seq #(eql = /= < > <= >=))) + (arg2 (rcase + (1 (make-array (list s2) :initial-contents arg2-args)) + (1 + (let* ((mask (1- (ash 1 (1+ (random 32)))))) + (make-array (list s2) + :initial-contents + (mapcar #'(lambda (x) (logand x mask)) arg2-args) + :element-type `(integer 0 ,mask)))) + (1 `(quote ,arg2-args))))) + `(,op ,arg1 ,arg2 ,@(rcase + (2 nil) + (1 (list :test `(quote ,test))) + (1 (list :test-not `(quote ,test))))))))) (defun make-random-integer-flet-call-form (size) (if *flet-names* (let* ((flet-entry (random-from-seq *flet-names*)) - (flet-name (car flet-entry)) - (flet-minargs (cadr flet-entry)) - (flet-maxargs (caddr flet-entry)) - (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) - ) - (cond - ((> nargs 0) - (let* ((arg-sizes (random-partition (1- size) nargs)) - (args (mapcar #'make-random-integer-form arg-sizes))) - (rcase - (1 `(,flet-name ,@args)) - (1 `(multiple-value-call #',flet-name (values ,@args))) - (1 `(funcall (function ,flet-name) ,@args)) - (1 (let ((r (random (1+ (length args))))) - `(apply (function ,flet-name) - ,@(subseq args 0 r) - (list ,@(subseq args r)))))))) - (t (make-random-integer-form size)))) + (flet-name (car flet-entry)) + (flet-minargs (cadr flet-entry)) + (flet-maxargs (caddr flet-entry)) + (nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) + ) + (cond + ((> nargs 0) + (let* ((arg-sizes (random-partition (1- size) nargs)) + (args (mapcar #'make-random-integer-form arg-sizes))) + (rcase + (1 `(,flet-name ,@args)) + (1 `(multiple-value-call #',flet-name (values ,@args))) + (1 `(funcall (function ,flet-name) ,@args)) + (1 (let ((r (random (1+ (length args))))) + `(apply (function ,flet-name) + ,@(subseq args 0 r) + (list ,@(subseq args r)))))))) + (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-unwind-protect-form (size) (let* ((op 'unwind-protect) - (nforms (random 4)) - (sizes (random-partition (1- size) (1+ nforms))) - (arg (make-random-integer-form (first sizes))) - (unwind-forms - ;; We have to be careful not to generate code that will - ;; illegally transfer control to a dead location - (let ((*flet-names* nil) - (*go-tags* nil) - (*random-int-form-blocks* nil) - (*random-int-form-catch-tags* nil)) - (mapcar #'make-random-integer-form (rest sizes))))) + (nforms (random 4)) + (sizes (random-partition (1- size) (1+ nforms))) + (arg (make-random-integer-form (first sizes))) + (unwind-forms + ;; We have to be careful not to generate code that will + ;; illegally transfer control to a dead location + (let ((*flet-names* nil) + (*go-tags* nil) + (*random-int-form-blocks* nil) + (*random-int-form-catch-tags* nil)) + (mapcar #'make-random-integer-form (rest sizes))))) `(,op ,arg ,@unwind-forms))) (defun make-random-integer-eval-form (size) (flet ((%arg (size) - (let ((*flet-names* nil) - (*vars* (remove-if-not #'(lambda (s) - (find (var-desc-name s) - *random-special-vars*)) - *vars*)) - (*random-int-form-blocks* nil) - (*go-tags* nil)) - (make-random-integer-form size)))) + (let ((*flet-names* nil) + (*vars* (remove-if-not #'(lambda (s) + (find (var-desc-name s) + *random-special-vars*)) + *vars*)) + (*random-int-form-blocks* nil) + (*go-tags* nil)) + (make-random-integer-form size)))) (rcase (2 `(eval ',(%arg (1- size)))) (2 (let* ((nargs (1+ (random 4))) - (sizes (random-partition (1- size) nargs)) - (args (mapcar #'%arg sizes))) - `(eval (values ,@args)))) + (sizes (random-partition (1- size) nargs)) + (args (mapcar #'%arg sizes))) + `(eval (values ,@args)))) ))) (defun make-random-type-for-var (var e1) @@ -674,28 +678,28 @@ (values (cond ((and (find var *random-special-vars*) - (setq desc (find var *vars* :key #'var-desc-name))) + (setq desc (find var *vars* :key #'var-desc-name))) (var-desc-type desc)) (t (rcase - (4 '(integer * *)) - (1 (setq e1 `(make-array nil :initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - '(array integer nil)) - (1 (let ((size (1+ (random 10)))) - (setq e1 `(make-array '(,size):initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - `(array integer (,size)))) - #| - (1 (let ((size1 (1+ (random 10))) - (size2 (1+ (random 10)))) - (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 - ,@(rcase (1 nil) (1 '(:adjustable t))))) - `(array integer (,size1 ,size2)))) - |# - (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) - '(cons integer integer)) - (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) - '(cons integer integer))))) + (4 '(integer * *)) + (1 (setq e1 `(make-array nil :initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + '(array integer nil)) + (1 (let ((size (1+ (random 10)))) + (setq e1 `(make-array '(,size):initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + `(array integer (,size)))) + #| + (1 (let ((size1 (1+ (random 10))) + (size2 (1+ (random 10)))) + (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1 + ,@(rcase (1 nil) (1 '(:adjustable t))))) + `(array integer (,size1 ,size2)))) + |# + (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1))) + '(cons integer integer)) + (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1)) + '(cons integer integer))))) e1))) (defun random2 (n) @@ -707,362 +711,362 @@ (defun make-random-integer-binding-form (size) (destructuring-bind (s1 s2) (random-partition (1- size) 2) (let* ((var (random-from-seq2 (rcase - (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) - #-ecl (2 *random-special-vars*) - ))) - (e1 (make-random-integer-form s1)) - (type (multiple-value-bind (type2 e) - (make-random-type-for-var var e1) - (setq e1 e) - type2)) - (e2 (let ((*vars* (cons (make-var-desc :name var :type type) - *vars*))) - (make-random-integer-form s2))) - (op (random-from-seq #(let let*)))) + (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) + #-ecl (2 *random-special-vars*) + ))) + (e1 (make-random-integer-form s1)) + (type (multiple-value-bind (type2 e) + (make-random-type-for-var var e1) + (setq e1 e) + type2)) + (e2 (let ((*vars* (cons (make-var-desc :name var :type type) + *vars*))) + (make-random-integer-form s2))) + (op (random-from-seq #(let let*)))) ;; for now, avoid shadowing (if (member var *vars* :key #'var-desc-name) - (make-random-integer-form size) - (rcase - (8 `(,op ((,var ,e1)) - ,@(rcase (1 `((declare (dynamic-extent ,var)))) - (3 nil)) - ,e2)) - (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) + (make-random-integer-form size) + (rcase + (8 `(,op ((,var ,e1)) + ,@(rcase (1 `((declare (dynamic-extent ,var)))) + (3 nil)) + ,e2)) + (2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (defun make-random-integer-progv-form (size) (let* ((num-vars (random 4)) - (possible-vars *random-special-vars*) - (vars nil)) + (possible-vars *random-special-vars*) + (vars nil)) (loop repeat num-vars - do (loop for r = (elt possible-vars (random (length possible-vars))) - while (member r vars) - finally (push r vars))) + do (loop for r = (elt possible-vars (random (length possible-vars))) + while (member r vars) + finally (push r vars))) (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name))) - (and desc (not (subtypep (var-desc-type desc) 'integer))))) - vars) - num-vars (length vars)) + (and desc (not (subtypep (var-desc-type desc) 'integer))))) + vars) + num-vars (length vars)) (if (null vars) - `(progv nil nil ,(make-random-integer-form (1- size))) + `(progv nil nil ,(make-random-integer-form (1- size))) (destructuring-bind (s1 s2) (random-partition (1- size) 2) - (let* ((var-sizes (random-partition s1 num-vars)) - (var-forms (mapcar #'make-random-integer-form var-sizes)) - (*vars* (append (loop for v in vars collect - (make-var-desc :name v :type '(integer * *))) - *vars*)) - (body-form (make-random-integer-form s2))) - `(progv ',vars (list ,@var-forms) ,body-form)))))) + (let* ((var-sizes (random-partition s1 num-vars)) + (var-forms (mapcar #'make-random-integer-form var-sizes)) + (*vars* (append (loop for v in vars collect + (make-var-desc :name v :type '(integer * *))) + *vars*)) + (body-form (make-random-integer-form s2))) + `(progv ',vars (list ,@var-forms) ,body-form)))))) (defun make-random-integer-mapping-form (size) ;; reduce (let ((keyargs nil) - (nargs (1+ (random (min 10 (max 1 size))))) - (sequence-op (random-from-seq '(vector list)))) + (nargs (1+ (random (min 10 (max 1 size))))) + (sequence-op (random-from-seq '(vector list)))) (when (coin 2) (setq keyargs '(:from-end t))) (cond ((coin 2) (let ((start (random nargs))) - (setq keyargs `(:start ,start ,@keyargs)) - (when (coin 2) - (let ((end (+ start 1 (random (- nargs start))))) - (setq keyargs `(:end ,end ,@keyargs)))))) + (setq keyargs `(:start ,start ,@keyargs)) + (when (coin 2) + (let ((end (+ start 1 (random (- nargs start))))) + (setq keyargs `(:end ,end ,@keyargs)))))) (t (when (coin 2) - (let ((end (1+ (random nargs)))) - (setq keyargs `(:end ,end ,@keyargs)))))) + (let ((end (1+ (random nargs)))) + (setq keyargs `(:end ,end ,@keyargs)))))) (rcase (1 (let ((sizes (random-partition (1- size) nargs)) - (op (random-from-seq #(+ - * logand logxor logior max min)))) - `(reduce ,(rcase (1 `(function ,op)) - (1 `(quote ,op))) - (,sequence-op - ,@(mapcar #'make-random-integer-form sizes)) - ,@keyargs))) + (op (random-from-seq #(+ - * logand logxor logior max min)))) + `(reduce ,(rcase (1 `(function ,op)) + (1 `(quote ,op))) + (,sequence-op + ,@(mapcar #'make-random-integer-form sizes)) + ,@keyargs))) #-(or armedbear) (1 (destructuring-bind (size1 size2) (random-partition (1- size) 2) - (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) - (var1 (random-from-seq vars)) - (var2 (random-from-seq (remove var1 vars))) - (form (let ((*vars* (list* - (make-var-desc :name var1 :type '(integer * *)) - (make-var-desc :name var2 :type '(integer * *)) - *vars*))) - (make-random-integer-form size1))) - (sizes (random-partition size2 nargs)) - (args (mapcar #'make-random-integer-form sizes))) - `(reduce (function (lambda (,var1 ,var2) ,form)) - (,sequence-op ,@args) - ,@keyargs))))))) + (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) + (var1 (random-from-seq vars)) + (var2 (random-from-seq (remove var1 vars))) + (form (let ((*vars* (list* + (make-var-desc :name var1 :type '(integer * *)) + (make-var-desc :name var2 :type '(integer * *)) + *vars*))) + (make-random-integer-form size1))) + (sizes (random-partition size2 nargs)) + (args (mapcar #'make-random-integer-form sizes))) + `(reduce (function (lambda (,var1 ,var2) ,form)) + (,sequence-op ,@args) + ,@keyargs))))))) (defun make-random-integer-setq-form (size) (if *vars* (let* ((vdesc (random-from-seq *vars*)) - (var (var-desc-name vdesc)) - (type (var-desc-type vdesc)) - (op (random-from-seq #(setq setf shiftf)))) - (cond - ((subtypep '(integer * *) type) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (rcase - (1 (when (find var *random-special-vars*) - (setq op (random-from-seq #(setf shiftf)) - var `(symbol-value ',var)))) - (1 (setq op 'multiple-value-setq) - (setq var (list var))) - (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) - `(,op ,var ,(make-random-integer-form (1- size)))) - ((and (consp type) - (eq (car type) 'integer) - (integerp (second type)) - (integerp (third type))) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (rcase - (1 (when (find var *random-special-vars*) - (setq op (random-from-seq #(setf shiftf)) - var `(symbol-value ',var)))) - (1 (setq op 'multiple-value-setq) - (setq var (list var))) - (5 nil)) - `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) - ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) - (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) - ((and type (subtypep type '(array integer (*)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) - `(,op (aref ,var (min ,(1- (first (third type))) - (max 0 - ,(make-random-integer-form s1)))) - ,(make-random-integer-form s2)))) - ((and type (subtypep type '(array integer (* *)))) - (when (eq op 'setq) - (setq op (random-from-seq #(setf shiftf)))) - (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) - `(,op (aref ,var - (min ,(1- (first (third type))) - (max 0 - ,(make-random-integer-form s1))) - (min ,(1- (second (third type))) - (max 0 - ,(make-random-integer-form s2)))) - ,(make-random-integer-form s3)))) - ;; Abort -- can't assign - (t (make-random-integer-form size)))) + (var (var-desc-name vdesc)) + (type (var-desc-type vdesc)) + (op (random-from-seq #(setq setf shiftf)))) + (cond + ((subtypep '(integer * *) type) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (rcase + (1 (when (find var *random-special-vars*) + (setq op (random-from-seq #(setf shiftf)) + var `(symbol-value ',var)))) + (1 (setq op 'multiple-value-setq) + (setq var (list var))) + (5 (setf op (random-from-seq #(setq setf shiftf incf decf))))) + `(,op ,var ,(make-random-integer-form (1- size)))) + ((and (consp type) + (eq (car type) 'integer) + (integerp (second type)) + (integerp (third type))) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (rcase + (1 (when (find var *random-special-vars*) + (setq op (random-from-seq #(setf shiftf)) + var `(symbol-value ',var)))) + (1 (setq op 'multiple-value-setq) + (setq var (list var))) + (5 nil)) + `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) + ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil)) + (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + `(,op (aref ,var) ,(make-random-integer-form (- size 2)))) + ((and type (subtypep type '(array integer (*)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2) + `(,op (aref ,var (min ,(1- (first (third type))) + (max 0 + ,(make-random-integer-form s1)))) + ,(make-random-integer-form s2)))) + ((and type (subtypep type '(array integer (* *)))) + (when (eq op 'setq) + (setq op (random-from-seq #(setf shiftf)))) + (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3) + `(,op (aref ,var + (min ,(1- (first (third type))) + (max 0 + ,(make-random-integer-form s1))) + (min ,(1- (second (third type))) + (max 0 + ,(make-random-integer-form s2)))) + ,(make-random-integer-form s3)))) + ;; Abort -- can't assign + (t (make-random-integer-form size)))) (make-random-integer-form size))) (defun make-random-integer-case-form (size) (let ((ncases (1+ (random 10)))) (if (< (+ size size) (+ ncases 2)) - ;; Too small, give up - (make-random-integer-form size) + ;; Too small, give up + (make-random-integer-form size) (let* ((sizes (random-partition (1- size) (+ ncases 2))) - (bound (ash 1 (+ 2 (random 16)))) - (lower-bound (if (coin 3) 0 (- bound))) - (upper-bound (if (and (< lower-bound 0) (coin 3)) - 1 - (1+ bound))) - (cases - (loop - for case-size in (cddr sizes) - for vals = (loop repeat (1+ (min (random 10) (random 10))) - collect (random-from-interval - upper-bound lower-bound)) - for result = (make-random-integer-form case-size) - repeat ncases - collect `(,vals ,result))) - (expr (make-random-integer-form (first sizes)))) - `(case ,expr - ,@cases - (t ,(make-random-integer-form (second sizes)))))))) + (bound (ash 1 (+ 2 (random 16)))) + (lower-bound (if (coin 3) 0 (- bound))) + (upper-bound (if (and (< lower-bound 0) (coin 3)) + 1 + (1+ bound))) + (cases + (loop + for case-size in (cddr sizes) + for vals = (loop repeat (1+ (min (random 10) (random 10))) + collect (random-from-interval + upper-bound lower-bound)) + for result = (make-random-integer-form case-size) + repeat ncases + collect `(,vals ,result))) + (expr (make-random-integer-form (first sizes)))) + `(case ,expr + ,@cases + (t ,(make-random-integer-form (second sizes)))))))) (defun make-random-flet-form (size) "Generate random flet, labels forms, for now with no arguments and a single binding per form." (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 - %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) + %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) (if (assoc fname *flet-names*) - ;; Fail if the name is in use - (make-random-integer-form size) + ;; Fail if the name is in use + (make-random-integer-form size) (let* ((op (random-from-seq #(flet labels))) - (minargs (random 4)) - (maxargs #+:allegro minargs - #-:allegro - (rcase - (1 minargs) - (1 (+ minargs (random 4))))) - (keyarg-p (coin 2)) - (keyarg-n (if keyarg-p (random 3) 0)) - (arg-names (loop for i from 1 to maxargs - collect (fn-arg-name fname i))) - (key-arg-names (loop for i from 1 to keyarg-n - collect (intern (format nil "KEY~A" i) - (find-package "CL-TEST")))) - (allow-other-keys (and keyarg-p (coin 3))) - ) - (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) - (s1 (car sizes)) - (s2 (cadr sizes)) - (opt-sizes (cddr sizes))) - (let* ((form1 - ;; Allow return-from of the flet/labels function - (let ((*random-int-form-blocks* - (cons fname *random-int-form-blocks*)) - (*vars* (nconc (loop for var in (append arg-names key-arg-names) - collect (make-var-desc :name var - :type '(integer * *))) - *vars*))) - (make-random-integer-form s1))) - (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) - *flet-names*))) - (make-random-integer-form s2))) - (opt-forms (mapcar #'make-random-integer-form opt-sizes) - )) - (if opt-forms - `(,op ((,fname (,@(subseq arg-names 0 minargs) - &optional - ,@(mapcar #'list - (subseq arg-names minargs) - opt-forms) - ,@(when keyarg-p - (append '(&key) - (mapcar #'list - key-arg-names - (subseq opt-forms (- maxargs minargs))) - (when allow-other-keys '(&allow-other-keys)) - ))) - ,form1)) - ,form2) - `(,op ((,fname (,@arg-names - ,@(when keyarg-p - (append '(&key) - (mapcar #'list - key-arg-names - opt-forms ) - (when allow-other-keys '(&allow-other-keys)) - ))) - ,form1)) - ,form2)))))))) + (minargs (random 4)) + (maxargs #+:allegro minargs + #-:allegro + (rcase + (1 minargs) + (1 (+ minargs (random 4))))) + (keyarg-p (coin 2)) + (keyarg-n (if keyarg-p (random 3) 0)) + (arg-names (loop for i from 1 to maxargs + collect (fn-arg-name fname i))) + (key-arg-names (loop for i from 1 to keyarg-n + collect (intern (format nil "KEY~A" i) + (find-package "CL-TEST")))) + (allow-other-keys (and keyarg-p (coin 3))) + ) + (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))) + (s1 (car sizes)) + (s2 (cadr sizes)) + (opt-sizes (cddr sizes))) + (let* ((form1 + ;; Allow return-from of the flet/labels function + (let ((*random-int-form-blocks* + (cons fname *random-int-form-blocks*)) + (*vars* (nconc (loop for var in (append arg-names key-arg-names) + collect (make-var-desc :name var + :type '(integer * *))) + *vars*))) + (make-random-integer-form s1))) + (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p) + *flet-names*))) + (make-random-integer-form s2))) + (opt-forms (mapcar #'make-random-integer-form opt-sizes) + )) + (if opt-forms + `(,op ((,fname (,@(subseq arg-names 0 minargs) + &optional + ,@(mapcar #'list + (subseq arg-names minargs) + opt-forms) + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + (subseq opt-forms (- maxargs minargs))) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2) + `(,op ((,fname (,@arg-names + ,@(when keyarg-p + (append '(&key) + (mapcar #'list + key-arg-names + opt-forms ) + (when allow-other-keys '(&allow-other-keys)) + ))) + ,form1)) + ,form2)))))))) (defun make-random-tagbody (size) (let* ((num-forms (random 6)) - (tags nil)) + (tags nil)) (loop for i below num-forms - do (loop for tag = (rcase - #-allegro (1 (random 8)) - (1 (random-from-seq #(tag1 tag2 tag3 tag4 - tag5 tag6 tag7 tag8)))) - while (member tag tags) - finally (push tag tags))) + do (loop for tag = (rcase + #-allegro (1 (random 8)) + (1 (random-from-seq #(tag1 tag2 tag3 tag4 + tag5 tag6 tag7 tag8)))) + while (member tag tags) + finally (push tag tags))) (assert (= (length (remove-duplicates tags)) (length tags))) (let* ((*go-tags* (set-difference *go-tags* tags)) - (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) - (forms - (loop for tag-list on tags - for i below num-forms - for size in sizes - collect (let ((*go-tags* (append tag-list *go-tags*))) - (make-random-integer-form size))))) + (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) + (forms + (loop for tag-list on tags + for i below num-forms + for size in sizes + collect (let ((*go-tags* (append tag-list *go-tags*))) + (make-random-integer-form size))))) `(tagbody ,@(loop for tag in tags - for form in forms - when (atom form) do (setq form `(progn ,form)) - append `(,form ,tag)))))) + for form in forms + when (atom form) do (setq form `(progn ,form)) + append `(,form ,tag)))))) (defun make-random-tagbody-and-progn (size) (let* ((final-size (random (max 1 (floor size 5)))) - (tagbody-size (- size final-size))) + (tagbody-size (- size final-size))) (let ((final-form (make-random-integer-form final-size)) - (tagbody-form (make-random-tagbody tagbody-size))) + (tagbody-form (make-random-tagbody tagbody-size))) `(progn ,tagbody-form ,final-form)))) (defun make-random-pred-form (size) "Make a random form whose value is to be used as a generalized boolean." (if (<= size 1) (rcase - (1 (if (coin) t nil)) - (2 - `(,(random-from-seq '(< <= = > >= /= eql equal)) - ,(make-random-integer-form size) - ,(make-random-integer-form size)))) + (1 (if (coin) t nil)) + (2 + `(,(random-from-seq '(< <= = > >= /= eql equal)) + ,(make-random-integer-form size) + ,(make-random-integer-form size)))) (rcase (1 (if (coin) t nil)) (3 `(not ,(make-random-pred-form (1- size)))) (12 (destructuring-bind (leftsize rightsize) - (random-partition (1- size) 2) - `(,(random-from-seq '(and or)) - ,(make-random-pred-form leftsize) - ,(make-random-pred-form rightsize)))) + (random-partition (1- size) 2) + `(,(random-from-seq '(and or)) + ,(make-random-pred-form leftsize) + ,(make-random-pred-form rightsize)))) (1 (let* ((nsizes (+ 1 (random 3))) - (sizes (random-partition (1- size) nsizes))) - `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) - #(< <= > >= = /=))) - ,@(mapcar #'make-random-integer-form sizes)))) + (sizes (random-partition (1- size) nsizes))) + `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal) + #(< <= > >= = /=))) + ,@(mapcar #'make-random-integer-form sizes)))) (3 (let* ((cond-size (random (max 1 (floor size 2)))) - (then-size (random (- size cond-size))) - (else-size (- size 1 cond-size then-size)) - (pred (make-random-pred-form cond-size)) - (then-part (make-random-pred-form then-size)) - (else-part (make-random-pred-form else-size))) - `(if ,pred ,then-part ,else-part))) + (then-size (random (- size cond-size))) + (else-size (- size 1 cond-size then-size)) + (pred (make-random-pred-form cond-size)) + (then-part (make-random-pred-form then-size)) + (else-part (make-random-pred-form else-size))) + `(if ,pred ,then-part ,else-part))) #-poplog (1 (destructuring-bind (s1 s2) - (random-partition (1- size) 2) - `(ldb-test ,(make-random-byte-spec-form s1) - ,(make-random-integer-form s2)))) + (random-partition (1- size) 2) + `(ldb-test ,(make-random-byte-spec-form s1) + ,(make-random-integer-form s2)))) (2 (let ((form (make-random-integer-form (1- size))) - (op (random-from-seq #(evenp oddp minusp plusp zerop)))) - `(,op ,form))) + (op (random-from-seq #(evenp oddp minusp plusp zerop)))) + `(,op ,form))) (2 (destructuring-bind (s1 s2) - (random-partition (1- size) 2) - (let ((arg1 (make-random-integer-form s1)) - (arg2-args (loop repeat s2 collect (make-random-integer)))) - (let ((op (random-from-seq #(find position))) - (test (random-from-seq #(eql = /= < > <= >=))) - (arg2 (rcase - (1 (make-array (list s2) :initial-contents arg2-args)) - (1 - (let* ((mask (1- (ash 1 (1+ (random 32)))))) - (make-array (list s2) - :initial-contents - (mapcar #'(lambda (x) (logand x mask)) arg2-args) - :element-type `(integer 0 ,mask)))) - (1 `(quote ,arg2-args))))) - `(,op ,arg1 ,arg2 ,@(rcase - (2 nil) - (1 (list :test `(quote ,test))) - (1 (list :test-not `(quote ,test))))))))) + (random-partition (1- size) 2) + (let ((arg1 (make-random-integer-form s1)) + (arg2-args (loop repeat s2 collect (make-random-integer)))) + (let ((op (random-from-seq #(find position))) + (test (random-from-seq #(eql = /= < > <= >=))) + (arg2 (rcase + (1 (make-array (list s2) :initial-contents arg2-args)) + (1 + (let* ((mask (1- (ash 1 (1+ (random 32)))))) + (make-array (list s2) + :initial-contents + (mapcar #'(lambda (x) (logand x mask)) arg2-args) + :element-type `(integer 0 ,mask)))) + (1 `(quote ,arg2-args))))) + `(,op ,arg1 ,arg2 ,@(rcase + (2 nil) + (1 (list :test `(quote ,test))) + (1 (list :test-not `(quote ,test))))))))) (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) - (form (make-random-integer-form (1- size)))) - `(logbitp ,index ,form))) + (form (make-random-integer-form (1- size)))) + `(logbitp ,index ,form))) (1 ;; typep form (let ((subform (make-random-integer-form (- size 2))) - (type - (rcase - (1 `(real ,@(make-random-integer-range))) - (1 `(rational ,@(make-random-integer-range))) - (1 `(rational ,(+ 1/2 (make-random-integer)))) - (1 `(rational * ,(+ 1/2 (make-random-integer)))) - (1 `(integer ,@(make-random-integer-range))) - (1 `(integer ,(make-random-integer))) - (1 `(integer * ,(make-random-integer))) - (1 'fixnum) - (1 'bignum) - (1 `(integer))))) - `(typep ,subform ',type))) + (type + (rcase + (1 `(real ,@(make-random-integer-range))) + (1 `(rational ,@(make-random-integer-range))) + (1 `(rational ,(+ 1/2 (make-random-integer)))) + (1 `(rational * ,(+ 1/2 (make-random-integer)))) + (1 `(integer ,@(make-random-integer-range))) + (1 `(integer ,(make-random-integer))) + (1 `(integer * ,(make-random-integer))) + (1 'fixnum) + (1 'bignum) + (1 `(integer))))) + `(typep ,subform ',type))) ))) (defun make-random-loop-form (size) (if (<= size 2) (make-random-integer-form size) (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4))) - (count (random 4)) - (*vars* (cons (make-var-desc :name var :type nil) - *vars*))) + (count (random 4)) + (*vars* (cons (make-var-desc :name var :type nil) + *vars*))) (rcase (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2)))) (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2)))) @@ -1071,7 +1075,7 @@ (defun make-random-byte-spec-form (size) (declare (ignore size)) (let* ((pform (random 33)) - (sform (1+ (random 33)))) + (sform (1+ (random 33)))) `(byte ,sform ,pform))) (defun make-random-element-of-type (type) @@ -1080,185 +1084,227 @@ ((consp type) (let ((type-op (first type))) (ecase type-op - (or - (assert (cdr type)) - (make-random-element-of-type (random-from-seq (cdr type)))) - (and - (assert (cdr type)) - (loop for x = (make-random-element-of-type (cadr type)) - repeat 100 - when (typep x (cons 'and (cddr type))) - return x - finally (error "Cannot generate random element of ~A" type))) - (not - (assert (cdr type)) - (assert (not (cddr type))) - (make-random-element-of-type `(and t ,type))) - (integer - (let ((lo (let ((lo (cadr type))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (caddr type))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) - (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - - (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) - - (rational - (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (cadr type)) + (or + (assert (cdr type)) + (make-random-element-of-type (random-from-seq (cdr type)))) + (and + (assert (cdr type)) + (loop for x = (make-random-element-of-type (cadr type)) + repeat 100 + when (typep x (cons 'and (cddr type))) + return x + finally (error "Cannot generate random element of ~A" type))) + (not + (assert (cdr type)) + (assert (not (cddr type))) + (make-random-element-of-type `(and t ,type))) + (integer + (let ((lo (let ((lo (cadr type))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (caddr type))) + (cond + ((consp hi) (1- (car hi))) + ((eq hi nil) '*) + (t hi))))) + (if (eq lo '*) + (if (eq hi '*) + (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval x (- x))) + (random-from-interval (1+ hi) + (- hi (random (ash 1 *maximum-random-int-bits*))))) + + (if (eq hi '*) + (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) + lo) + ;; May generalize the next case to increase odds + ;; of certain integers (near 0, near endpoints, near + ;; powers of 2...) + (random-from-interval (1+ hi) lo))))) + + (rational + (or + (let ((r (make-random-element-of-type 'rational))) + (and (typep r type) r)) + (let ((lo (cadr type)) + (hi (caddr type)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo nil) + (setq lo= nil)) + (t + (assert (typep lo 'rational)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi nil) + (setq hi= nil)) + (t + (assert (typep hi 'rational)) + (setq hi= t))) + (assert (or (null lo) (null hi) (<= lo hi))) + (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (cond + ((null lo) + (cond + ((null hi) (make-random-rational)) + (hi= (- hi (make-random-nonnegative-rational))) + (t (- hi (make-random-positive-rational))))) + ((null hi) + (cond + (lo= (+ lo (make-random-nonnegative-rational))) + (t (+ lo (make-random-positive-rational))))) + (t + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) + + (ratio + (let ((r 0)) + (loop + do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) + while (integerp r)) + r)) + + (real + (rcase + (1 (let ((lo (and (numberp (cadr type)) + (rational (cadr type)))) + (hi (and (numberp (caddr type)) + (rational (caddr type))))) + (make-random-element-of-type `(rational ,(or lo '*) + ,(or hi '*))))) + (1 (make-random-element-of-type `(float ,(or (cadr type) '*) + ,(or (caddr type) '*)))))) + + ((float) + (let* ((new-type-op (random-from-seq #(single-float double-float + long-float short-float))) + (lo (cadr type)) (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) - - ((single-float double-float long-float short-float) - (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo (most-negative-float type-op)) - (setq lo= t)) - (t - (assert (typep lo type-op)) - (setq lo= t))) + (most-neg (most-negative-float new-type-op)) + (most-pos (most-positive-float new-type-op))) (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi (most-positive-float type-op)) - (setq hi= t)) + ((or (and (realp lo) (< lo most-neg)) + (and (realp hi) (> hi most-pos))) + ;; try again + (make-random-element-of-type type)) (t - (assert (typep hi type-op)) - (setq hi= t))) - (assert (<= lo hi)) - (assert (or (< lo hi) (and lo= hi=))) - (let ((limit 100000)) - (cond - ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) - (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) + (when (and (realp lo) (not (typep lo new-type-op))) + (cond + ((< lo most-neg) (setq lo '*)) + (t (setq lo (coerce lo new-type-op))))) + (when (and (realp hi) (not (typep hi new-type-op))) + (cond + ((> hi most-pos) (setq hi '*)) + (t (setq hi (coerce hi new-type-op))))) + (make-random-element-of-type + `(,new-type-op ,(or lo '*) ,(or hi '*))))))) - (mod - (let ((modulus (second type))) - (assert (and (integerp modulus) - (plusp modulus))) - (make-random-element-of-type `(integer 0 (,modulus))))) - (unsigned-byte - (if (null (cdr type)) - (make-random-element-of-type '(integer 0 *)) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) - (signed-byte - (if (null (cdr type)) - (make-random-element-of-type 'integer) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) - (eql - (assert (= (length type) 2)) - (cadr type)) - (member - (assert (cdr type)) - (random-from-seq (cdr type))) - ((vector) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-vector etype-spec size-spec))) - ((simple-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector t size-spec :simple t))) - ((array simple-array) - (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) - ((string simple-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-string size-spec :simple (eql (car type) 'simple-string)))) - ((base-string simple-base-string) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) - ((bit-vector simple-bit-vector) - (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) - ((cons) - (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) - (make-random-element-of-type (if (cddr type) (caddr type) t)))) - ((complex) - (cond - ((null (cdr type)) - (make-random-element-of-type 'complex)) - (t - (assert (null (cddr type))) - (let ((etype (cadr type))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c type) - return c))))) - ))) + ((single-float double-float long-float short-float) + (let ((lo (cadr type)) + (hi (caddr type)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo (most-negative-float type-op)) + (setq lo= t)) + (t + (assert (typep lo type-op)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi (most-positive-float type-op)) + (setq hi= t)) + (t + (assert (typep hi type-op)) + (setq hi= t))) + (assert (<= lo hi)) + (assert (or (< lo hi) (and lo= hi=))) + (let ((limit 100000)) + (cond + ((or (<= hi 0) + (>= lo 0) + (and (<= (- limit) hi limit) (<= (- limit) lo limit))) + (loop for x = (+ (random (- hi lo)) lo) + do (when (or lo= (/= x lo)) (return x)))) + (t + (rcase + (1 (random (min hi (float limit hi)))) + (1 (- (random (min (float limit lo) (- lo))))))))))) + + (mod + (let ((modulus (second type))) + (assert (and (integerp modulus) + (plusp modulus))) + (make-random-element-of-type `(integer 0 (,modulus))))) + (unsigned-byte + (if (null (cdr type)) + (make-random-element-of-type '(integer 0 *)) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) + (signed-byte + (if (null (cdr type)) + (make-random-element-of-type 'integer) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type 'integer) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) + (eql + (assert (= (length type) 2)) + (cadr type)) + (member + (assert (cdr type)) + (random-from-seq (cdr type))) + ((vector) + (let ((etype-spec (if (cdr type) (cadr type) '*)) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-vector etype-spec size-spec))) + ((simple-vector) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector t size-spec :simple t))) + ((array simple-array) + (let ((etype-spec (if (cdr type) (cadr type) '*)) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) + ((string simple-string) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-string size-spec :simple (eql (car type) 'simple-string)))) + ((base-string simple-base-string) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) + ((bit-vector simple-bit-vector) + (let ((size-spec (if (cdr type) (cadr type) '*))) + (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) + ((cons) + (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) + (make-random-element-of-type (if (cddr type) (caddr type) t)))) + ((complex) + (cond + ((null (cdr type)) + (make-random-element-of-type 'complex)) + (t + (assert (null (cddr type))) + (let ((etype (cadr type))) + (loop for v1 = (make-random-element-of-type etype) + for v2 = (make-random-element-of-type etype) + for c = (complex v1 v2) + when (typep c type) + return c))))) + ))) ((typep type 'class) (make-random-element-of-type (class-name type))) (t @@ -1268,13 +1314,17 @@ (symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) (keyword (random-from-seq #(:a :b :c :d :e :f :g :h :i :j))) (unsigned-byte (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) + (1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (signed-byte (random-from-interval - (1+ (ash 1 (random *maximum-random-int-bits*))) - (- (ash 1 (random *maximum-random-int-bits*))))) + (1+ (ash 1 (random *maximum-random-int-bits*))) + (- (ash 1 (random *maximum-random-int-bits*))))) (rational (locally (declare (notinline make-random-rational)) (make-random-rational))) + (ratio (let ((r 0)) + (loop do (setq r (make-random-element-of-type 'rational)) + while (integerp r)) + r)) (integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval (1+ x) (- x)))) + (random-from-interval (1+ x) (- x)))) ((single-float short-float double-float long-float) (make-random-element-of-type (list type))) ((float) @@ -1298,9 +1348,9 @@ ((extended-char) (loop for x = (make-random-character) when (typep x 'extended-char) return x)) ;; Default ((atom t *) (make-random-element-of-type - (random-from-seq #(real symbol boolean integer unsigned-byte - #-ecl complex character - (string 1) (bit-vector 1))))) + (random-from-seq #(real symbol boolean integer unsigned-byte + #-ecl complex character + (string 1) (bit-vector 1))))) ((null) nil) ((fixnum) (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) @@ -1310,7 +1360,7 @@ (make-random-element-of-type '(cons t t))) ((list) (let ((len (min (random 10) (random 10)))) - (loop repeat len collect (make-random-element-of-type t)))) + (loop repeat len collect (make-random-element-of-type t)))) ((sequence) (make-random-element-of-type '(or list vector))) )))) @@ -1318,11 +1368,11 @@ (defun make-random-character () (loop when (rcase - (3 (random-from-seq +standard-chars+)) - (3 (code-char (random (min 256 char-code-limit)))) - (1 (code-char (random (min (ash 1 16) char-code-limit)))) - (1 (code-char (random (min (ash 1 24) char-code-limit)))) - (1 (code-char (random char-code-limit)))) + (3 (random-from-seq +standard-chars+)) + (3 (code-char (random (min 256 char-code-limit)))) + (1 (code-char (random (min (ash 1 16) char-code-limit)))) + (1 (code-char (random (min (ash 1 24) char-code-limit)))) + (1 (code-char (random char-code-limit)))) return it)) (defun make-random-array-element-type () @@ -1340,33 +1390,33 @@ (defun make-random-vector (etype-spec size-spec &key simple) (let* ((etype (if (eql etype-spec '*) - (make-random-array-element-type) - etype-spec)) - (size (if (eql size-spec '*) - (random (ash 1 (+ 2 (random 8)))) - size-spec)) - (displaced? (and (not simple) (coin 4))) - (displaced-size (+ size (random (max 6 size)))) - (displacement (random (1+ (- displaced-size size)))) - (adjustable (and (not simple) (coin 3))) - (fill-pointer (and (not simple) - (rcase (3 nil) (1 t) (1 (random (1+ size))))))) + (make-random-array-element-type) + etype-spec)) + (size (if (eql size-spec '*) + (random (ash 1 (+ 2 (random 8)))) + size-spec)) + (displaced? (and (not simple) (coin 4))) + (displaced-size (+ size (random (max 6 size)))) + (displacement (random (1+ (- displaced-size size)))) + (adjustable (and (not simple) (coin 3))) + (fill-pointer (and (not simple) + (rcase (3 nil) (1 t) (1 (random (1+ size))))))) (assert (<= size 1000000)) (if displaced? - (let ((displaced-vector (make-array displaced-size :element-type etype - :initial-contents (loop repeat displaced-size - collect (make-random-element-of-type etype))))) - (make-array size :element-type etype :adjustable adjustable - :fill-pointer fill-pointer - :displaced-to displaced-vector - :displaced-index-offset displacement)) + (let ((displaced-vector (make-array displaced-size :element-type etype + :initial-contents (loop repeat displaced-size + collect (make-random-element-of-type etype))))) + (make-array size :element-type etype :adjustable adjustable + :fill-pointer fill-pointer + :displaced-to displaced-vector + :displaced-index-offset displacement)) (make-array size - :element-type etype - :initial-contents (loop repeat size - collect (make-random-element-of-type etype)) - :adjustable adjustable - :fill-pointer fill-pointer - )))) + :element-type etype + :initial-contents (loop repeat size + collect (make-random-element-of-type etype)) + :adjustable adjustable + :fill-pointer fill-pointer + )))) (defun make-random-array (etype-spec dim-specs &key simple) (when (eql dim-specs '*) @@ -1374,25 +1424,25 @@ (when (numberp dim-specs) (setq dim-specs (make-list dim-specs :initial-element '*))) (let* ((etype (if (eql etype-spec '*) t etype-spec)) - (rank (length dim-specs)) - (dims (loop for dim in dim-specs - collect (if (eql dim '*) - (1+ (random (ash 1 (floor 9 rank)))) - dim)))) + (rank (length dim-specs)) + (dims (loop for dim in dim-specs + collect (if (eql dim '*) + (1+ (random (ash 1 (floor 9 rank)))) + dim)))) (assert (<= (reduce '* dims :initial-value 1) 1000000)) (assert (<= (reduce 'max dims :initial-value 1) 1000000)) (make-array dims - :element-type etype - :initial-contents - (labels ((%init (dims) - (if (null dims) - (make-random-element-of-type etype) - (loop repeat (car dims) - collect (%init (cdr dims)))))) - (%init dims)) - :adjustable (and (not simple) (coin)) - ;; Do displacements later - ))) + :element-type etype + :initial-contents + (labels ((%init (dims) + (if (null dims) + (make-random-element-of-type etype) + (loop repeat (car dims) + collect (%init (cdr dims)))))) + (%init dims)) + :adjustable (and (not simple) (coin)) + ;; Do displacements later + ))) (defun most-negative-float (float-type-symbol) (ecase float-type-symbol @@ -1401,7 +1451,7 @@ (double-float most-negative-double-float) (long-float most-negative-long-float) (float (min most-negative-short-float most-negative-single-float - most-negative-double-float most-negative-long-float)))) + most-negative-double-float most-negative-long-float)))) (defun most-positive-float (float-type-symbol) (ecase float-type-symbol @@ -1410,12 +1460,12 @@ (double-float most-positive-double-float) (long-float most-positive-long-float) (float (max most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float)))) + most-positive-double-float most-positive-long-float)))) (defun make-optimized-lambda-form (form vars var-types opt-decls) `(lambda ,vars ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var))) - var-types vars) + var-types vars) (declare (ignorable ,@vars)) #+cmu (declare (optimize (extensions:inhibit-warnings 3))) (declare (optimize ,@opt-decls)) @@ -1446,115 +1496,115 @@ ;; Return a non-nil list of details if a problem is found, ;; NIL otherwise. (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1)) - (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) + (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2))) (setq *int-form-vals* nil - *optimized-fn-src* optimized-fn-src - *unoptimized-fn-src* unoptimized-fn-src) + *optimized-fn-src* optimized-fn-src + *unoptimized-fn-src* unoptimized-fn-src) (flet ((%compile - (lambda-form opt-defun-name) - (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning) - ((or error serious-condition) - #'(lambda (c) - (format t "Compilation failure~%~A~%" - (format nil "~S" form)) - (finish-output *standard-output*) - (return-from test-int-form - (list (list :vars vars - :form form - :var-types var-types - :vals (first vals-list) - :lambda-form lambda-form - :decls1 opt-decls-1 - :decls2 opt-decls-2 - :compiler-condition - (with-output-to-string - (s) - (prin1 c s)))))))) - (let ((start-time (get-universal-time)) - (clf (cdr lambda-form))) - (prog1 - (cond - (*compile-using-defun* - (fmakunbound opt-defun-name) - (eval `(defun ,opt-defun-name ,@clf)) - (compile opt-defun-name) - (symbol-function opt-defun-name)) - (*compile-using-defgeneric* - (fmakunbound opt-defun-name) - (eval `(defgeneric ,opt-defun-name ,(car clf))) - (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) - ,@(cdr clf))) - (compile opt-defun-name) - (symbol-function opt-defun-name)) - (t (compile nil lambda-form))) - (let* ((stop-time (get-universal-time)) - (total-time (- stop-time start-time))) - (when (> total-time *max-compile-time*) - (setf *max-compile-time* total-time) - (setf *max-compile-term* lambda-form))) - ;; #+:ecl (si:gc t) - ))))) + (lambda-form opt-defun-name) + (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning) + ((or error serious-condition) + #'(lambda (c) + (format t "Compilation failure~%~A~%" + (format nil "~S" form)) + (finish-output *standard-output*) + (return-from test-int-form + (list (list :vars vars + :form form + :var-types var-types + :vals (first vals-list) + :lambda-form lambda-form + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :compiler-condition + (with-output-to-string + (s) + (prin1 c s)))))))) + (let ((start-time (get-universal-time)) + (clf (cdr lambda-form))) + (prog1 + (cond + (*compile-using-defun* + (fmakunbound opt-defun-name) + (eval `(defun ,opt-defun-name ,@clf)) + (compile opt-defun-name) + (symbol-function opt-defun-name)) + (*compile-using-defgeneric* + (fmakunbound opt-defun-name) + (eval `(defgeneric ,opt-defun-name ,(car clf))) + (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) + ,@(cdr clf))) + (compile opt-defun-name) + (symbol-function opt-defun-name)) + (t (compile nil lambda-form))) + (let* ((stop-time (get-universal-time)) + (total-time (- stop-time start-time))) + (when (> total-time *max-compile-time*) + (setf *max-compile-time* total-time) + (setf *max-compile-term* lambda-form))) + ;; #+:ecl (si:gc t) + ))))) (let ((optimized-compiled-fn (%compile optimized-fn-src - *name-to-use-in-optimized-defun*)) - (unoptimized-compiled-fn - (if *compile-unoptimized-form* - (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) - (eval `(function ,unoptimized-fn-src))))) - (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) - (dolist (vals vals-list) - (setq *int-form-vals* vals) - (flet ((%eval-error - (kind) - (let ((*print-circle* t)) - (format t "~A~%" (format nil "~S" form))) - (finish-output *standard-output*) - (return - (list (list :vars vars - :vals vals - :form form - :var-types var-types - :decls1 opt-decls-1 - :decls2 opt-decls-2 - :optimized-lambda-form optimized-fn-src - :unoptimized-lambda-form unoptimized-fn-src - :kind kind))))) - - (let ((unopt-result - (cl-handler-case - (cl-handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (identity ;; multiple-value-list - (apply unoptimized-compiled-fn vals))) - ((or error serious-condition) - (c) - (%eval-error (list :unoptimized-form-error - (with-output-to-string - (s) (prin1 c s))))))) - (opt-result - (cl-handler-case - (cl-handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (identity ;; multiple-value-list - (apply optimized-compiled-fn vals))) - ((or error serious-condition) - (c) - (%eval-error (list :optimized-form-error - (with-output-to-string - (s) (prin1 c s)))))))) - (if (equal opt-result unopt-result) - nil - (progn - (format t "Different results: ~A, ~A~%" - opt-result unopt-result) - (setq *opt-result* opt-result - *unopt-result* unopt-result) - (%eval-error (list :different-results - opt-result - unopt-result))))))))))) + *name-to-use-in-optimized-defun*)) + (unoptimized-compiled-fn + (if *compile-unoptimized-form* + (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) + (eval `(function ,unoptimized-fn-src))))) + (declare (type function optimized-compiled-fn unoptimized-compiled-fn)) + (dolist (vals vals-list) + (setq *int-form-vals* vals) + (flet ((%eval-error + (kind) + (let ((*print-circle* t)) + (format t "~A~%" (format nil "~S" form))) + (finish-output *standard-output*) + (return + (list (list :vars vars + :vals vals + :form form + :var-types var-types + :decls1 opt-decls-1 + :decls2 opt-decls-2 + :optimized-lambda-form optimized-fn-src + :unoptimized-lambda-form unoptimized-fn-src + :kind kind))))) + + (let ((unopt-result + (cl-handler-case + (cl-handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply unoptimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :unoptimized-form-error + (with-output-to-string + (s) (prin1 c s))))))) + (opt-result + (cl-handler-case + (cl-handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (identity ;; multiple-value-list + (apply optimized-compiled-fn vals))) + ((or error serious-condition) + (c) + (%eval-error (list :optimized-form-error + (with-output-to-string + (s) (prin1 c s)))))))) + (if (equal opt-result unopt-result) + nil + (progn + (format t "Different results: ~A, ~A~%" + opt-result unopt-result) + (setq *opt-result* opt-result + *unopt-result* unopt-result) + (%eval-error (list :different-results + opt-result + unopt-result))))))))))) ;;; Interface to the form pruner @@ -1564,43 +1614,43 @@ "Conduct tests on selected simplified versions of INPUT-FORM. Return the minimal form that still causes some kind of failure." (loop do - (let ((form input-form)) - (flet ((%try-fn (new-form) - (when (test-int-form new-form vars var-types vals-list - opt-decls-1 opt-decls-2) - (setf form new-form) - (throw 'success nil)))) - (let ((*prune-table* (make-hash-table :test #'eq))) - (loop - (catch 'success - (prune form #'%try-fn) - (return form))))) - (when (equal form input-form) (return form)) - (setq input-form form)))) + (let ((form input-form)) + (flet ((%try-fn (new-form) + (when (test-int-form new-form vars var-types vals-list + opt-decls-1 opt-decls-2) + (setf form new-form) + (throw 'success nil)))) + (let ((*prune-table* (make-hash-table :test #'eq))) + (loop + (catch 'success + (prune form #'%try-fn) + (return form))))) + (when (equal form input-form) (return form)) + (setq input-form form)))) (defun prune-results (result-list) "Given a list of test results, prune their forms down to a minimal set." (loop for result in result-list - collect - (let* ((form (getf result :form)) - (vars (getf result :vars)) - (var-types (getf result :var-types)) - (vals-list (list (getf result :vals))) - (opt-decl-1 (getf result :decls1)) - (opt-decl-2 (getf result :decls2)) - (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) - (optimized-lambda-form (make-optimized-lambda-form - pruned-form vars var-types opt-decl-1)) - (unoptimized-lambda-form (make-unoptimized-lambda-form - pruned-form vars var-types opt-decl-2))) - `(:vars ,vars - :var-types ,var-types - :vals ,(first vals-list) - :form ,pruned-form - :decls1 ,opt-decl-1 - :decls2 ,opt-decl-2 - :optimized-lambda-form ,optimized-lambda-form - :unoptimized-lambda-form ,unoptimized-lambda-form)))) + collect + (let* ((form (getf result :form)) + (vars (getf result :vars)) + (var-types (getf result :var-types)) + (vals-list (list (getf result :vals))) + (opt-decl-1 (getf result :decls1)) + (opt-decl-2 (getf result :decls2)) + (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2)) + (optimized-lambda-form (make-optimized-lambda-form + pruned-form vars var-types opt-decl-1)) + (unoptimized-lambda-form (make-unoptimized-lambda-form + pruned-form vars var-types opt-decl-2))) + `(:vars ,vars + :var-types ,var-types + :vals ,(first vals-list) + :form ,pruned-form + :decls1 ,opt-decl-1 + :decls2 ,opt-decl-2 + :optimized-lambda-form ,optimized-lambda-form + :unoptimized-lambda-form ,unoptimized-lambda-form)))) ;;; ;;; The call (PRUNE form try-fn) attempts to simplify the lisp form @@ -1621,572 +1671,572 @@ (unless (zerop form) (try 0))) ((consp form) (let* ((op (car form)) - (args (cdr form)) - (nargs (length args))) - (case op - - ((quote) nil) - - ((go) - (try 0)) - - ((signum integer-length logcount - logandc1 logandc2 lognand lognor logorc1 logorc2 - realpart imagpart) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((make-array) - (when (and (eq (car args) nil) - (eq (cadr args) ':initial-element) - ; (null (cdddr args)) - ) - (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) - (when (cdddr args) - (try `(make-array nil :initial-element ,(caddr args)))) - )) - - ((cons) - (prune-fn form try-fn)) - - ((dotimes) - (try 0) - (let* ((binding-form (first args)) - (body (rest args)) - (var (first binding-form)) - (count-form (second binding-form)) - (result (third binding-form))) - (try result) - (unless (eql count-form 0) - (try `(dotimes (,var 0 ,result) ,@body))) - (prune result #'(lambda (form) - (try `(dotimes (,var ,count-form ,form) ,@body)))) - (when (= (length body) 1) - (prune (first body) - #'(lambda (form) - (when (consp form) - (try `(dotimes (,var ,count-form ,result) ,form)))))))) - - ((abs 1+ 1-) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((identity ignore-errors cl:handler-case restart-case locally) - (unless (and (consp args) - (consp (car args)) - (eql (caar args) 'tagbody)) - (mapc try-fn args)) - (prune-fn form try-fn)) - - ((boole) - (try (second args)) - (try (third args)) - (prune (second args) - #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) - (prune (third args) - #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) - - ((unwind-protect prog1 multiple-value-prog1) - (try (first args)) - (let ((val (first args)) - (rest (rest args))) - (when rest - (try `(unwind-protect ,val)) - (when (cdr rest) - (loop for i from 0 below (length rest) - do - (try `(unwind-protect ,val - ,@(subseq rest 0 i) - ,@(subseq rest (1+ i)))))))) - (prune-fn form try-fn)) - - ((prog2) - (assert (>= (length args) 2)) - (let ((val1 (first args)) - (arg2 (second args)) - (rest (cddr args))) - (try arg2) - (prune-fn form try-fn) - (when rest - (try `(prog2 ,val1 ,arg2)) - (when (cdr rest) - (loop for i from 0 below (length rest) - do - (try `(prog2 ,val1 ,arg2 - ,@(subseq rest 0 i) - ,@(subseq rest (1+ i))))))))) - - ((typep) - (try (car args)) - (prune (car args) - #'(lambda (form) `(,op ,form ,@(cdr args))))) - - ((load-time-value) - (let ((arg (first args))) - (try arg) - (cond - ((cdr args) - (try `(load-time-value ,arg)) - (prune arg - #'(lambda (form) - (try `(load-time-value ,form ,(second args)))))) - (t - (prune arg - #'(lambda (form) - (try `(load-time-value ,form)))))))) - - ((eval) - (try 0) - (let ((arg (first args))) - (cond - ((consp arg) - (cond - ((eql (car arg) 'quote) - (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) - (t - (try arg) - (prune arg #'(lambda (form) `(eval ,form)))))) - (t (try arg))))) - - ((the macrolet cl:handler-bind restart-bind) - (assert (= (length args) 2)) - (try (second args)) - (prune (second args) try-fn)) - - ((not eq eql equal) - (when (every #'constantp args) - (try (eval form))) - (try t) - (try nil) - (mapc try-fn args) - (prune-fn form try-fn) - ) - - ((and or = < > <= >= /=) - (when (every #'constantp args) - (try (eval form))) - (try t) - (try nil) - (mapc try-fn args) - (prune-nary-fn form try-fn) - (prune-fn form try-fn)) - - ((- + * min max logand logior logxor logeqv gcd lcm values) - (when (every #'constantp args) - (try (eval form))) - (try 0) - (mapc try-fn args) - (prune-nary-fn form try-fn) - (prune-fn form try-fn)) - - ((/) - (when (every #'constantp args) - (try (eval form))) - (try 0) - (try (car args)) - (when (cddr args) - (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) - - ((expt rationalize rational numberator denominator) - (try 0) - (mapc try-fn args) - (prune-fn form try-fn)) - - ((coerce) - (try 0) - (try (car args)) - (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args)))))) - - - ((multiple-value-call) - ;; Simplify usual case - (when (= nargs 2) - (destructuring-bind (arg1 arg2) args - (when (and (consp arg1) (consp arg2) - (eql (first arg1) 'function) - (eql (first arg2) 'values)) - (mapc try-fn (rest arg2)) - (let ((fn (second arg1))) - (when (symbolp fn) - (try `(,fn ,@(rest arg2))))) - ;; Prune the VALUES form - (prune-list (rest arg2) - #'prune - #'(lambda (args) - (try `(multiple-value-call ,arg1 (values ,@args))))) - ))) - (mapc try-fn (rest args))) - - ((bit sbit elt aref svref) - (try 0) - (when (= (length args) 2) - (let ((arg1 (car args)) - (arg2 (cadr args))) - (when (and (consp arg2) - (eql (car arg2) 'min) - (integerp (cadr arg2))) - (let ((arg2.2 (caddr arg2))) - (try arg2.2) - (when (and (consp arg2.2) - (eql (car arg2.2) 'max) - (integerp (cadr arg2.2))) - (prune (caddr arg2.2) - #'(lambda (form) - (try `(,op ,arg1 (min ,(cadr arg2) - (max ,(cadr arg2.2) ,form)))))))))))) - - ((car cdr) - (try 0) - (try 1)) - - ((if) - (let (;; (pred (first args)) - (then (second args)) - (else (third args))) - (try then) - (try else) - (when (every #'constantp args) - (try (eval form))) - (prune-fn form try-fn))) - - ((incf decf) - (try 0) - (assert (member (length form) '(2 3))) - (try (first args)) - (when (> (length args) 1) - (try (second args)) - (try `(,op ,(first args))) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form))))))) - - ((setq setf shiftf) - (try 0) - ;; Assumes only one assignment - (assert (= (length form) 3)) - (try (first args)) - (try (second args)) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form)))))) - - ((rotatef) - (try 0) - (mapc try-fn (cdr form))) - - ((multiple-value-setq) - (try 0) - ;; Assumes only one assignment, and one variable - (assert (= (length form) 3)) - (assert (= (length (first args)) 1)) - (try `(setq ,(caar args) ,(cadr args))) - (unless (integerp (second args)) - (prune (second args) - #'(lambda (form) - (try `(,op ,(first args) ,form)))))) - - ((byte) - (prune-fn form try-fn)) - - ((deposit-field dpb) - (try 0) - (destructuring-bind (a1 a2 a3) - args - (try a1) - (try a3) - (when (and (integerp a1) - (integerp a3) - (and (consp a2) - (eq (first a2) 'byte) - (integerp (second a2)) - (integerp (third a2)))) - (try (eval form)))) - (prune-fn form try-fn)) - - ((ldb mask-field) - (try 0) - (try (second args)) - (when (and (consp (first args)) - (eq 'byte (first (first args))) - (every #'numberp (cdr (first args))) - (numberp (second args))) - (try (eval form))) - (prune-fn form try-fn)) - - ((ldb-test) - (try t) - (try nil) - (prune-fn form try-fn)) - - ((let let*) - (prune-let form try-fn)) - - ((multiple-value-bind) - (assert (= (length args) 3)) - (let ((arg1 (first args)) - (arg2 (second args)) - (body (caddr args))) - (when (= (length arg1) 1) - (try `(let ((,(first arg1) ,arg2)) ,body))) - (prune arg2 #'(lambda (form) - (try `(multiple-value-bind ,arg1 ,form ,body)))) - (prune body #'(lambda (form) - (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) - - ((block) - (let ((name (second form)) - (body (cddr form))) - (when (and body (null (cdr body))) - (let ((form1 (first body))) - - ;; Try removing the block entirely if it is not in use - (when (not (find-in-tree name body)) - (try form1)) - - ;; Try removing the block if its only use is an immediately - ;; enclosed return-from: (block <n> (return-from <n> <e>)) - (when (and (consp form1) - (eq (first form1) 'return-from) - (eq (second form1) name) - (not (find-in-tree name (third form1)))) - (try (third form1))) - - ;; Otherwise, try to simplify the subexpression - (prune form1 - #'(lambda (x) - (try `(block ,name ,x)))))))) - - ((catch) - (let* ((tag (second form)) - (name (if (consp tag) (cadr tag) tag)) - (body (cddr form))) - (when (and body (null (cdr body))) - (let ((form1 (first body))) - - ;; Try removing the catch entirely if it is not in use - ;; We make assumptions here about what throws can - ;; be present. - (when (or (not (find-in-tree 'throw body)) - (not (find-in-tree name body))) - (try form1)) - - ;; Try removing the block if its only use is an immediately - ;; enclosed return-from: (block <n> (return-from <n> <e>)) - (when (and (consp form1) - (eq (first form1) 'throw) - (equal (second form1) name) - (not (find-in-tree name (third form1)))) - (try (third form1))) - - ;; Otherwise, try to simplify the subexpression - (prune form1 - #'(lambda (x) - (try `(catch ,tag ,x)))))))) - - ((throw) - (try (second args)) - (prune (second args) - #'(lambda (x) (try `(throw ,(first args) ,x))))) - - ((flet labels) - (try 0) - (prune-flet form try-fn)) - - ((case) - (prune-case form try-fn)) - - ((isqrt) - (let ((arg (second form))) - (assert (null (cddr form))) - (assert (consp arg)) - (assert (eq (first arg) 'abs)) - (let ((arg2 (second arg))) - (try arg2) - ;; Try to fold - (when (integerp arg2) - (try (isqrt (abs arg2)))) - ;; Otherwise, simplify arg2 - (prune arg2 #'(lambda (form) - (try `(isqrt (abs ,form)))))))) - - ((ash) - (try 0) - (let ((form1 (second form)) - (form2 (third form))) - (try form1) - (try form2) - (prune form1 - #'(lambda (form) - (try `(ash ,form ,form2)))) - (when (and (consp form2) - (= (length form2) 3)) - (when (and (integerp form1) - (eq (first form2) 'min) - (every #'integerp (cdr form2))) - (try (eval form))) - (let ((form3 (third form2))) - (prune form3 - #'(lambda (form) - (try - `(ash ,form1 (,(first form2) ,(second form2) - ,form))))))))) - - ((floor ceiling truncate round mod rem) - (try 0) - (let ((form1 (second form)) - (form2 (third form))) - (try form1) - (when (cddr form) (try form2)) - (prune form1 - (if (cddr form) - #'(lambda (form) - (try `(,op ,form ,form2))) - #'(lambda (form) (try `(,op ,form))))) - (when (and (consp form2) - (= (length form2) 3)) - (when (and (integerp form1) - (member (first form2) '(max min)) - (every #'integerp (cdr form2))) - (try (eval form))) - (let ((form3 (third form2))) - (prune form3 - #'(lambda (form) - (try - `(,op ,form1 (,(first form2) ,(second form2) - ,form))))))))) - - ((constantly) - (unless (eql (car args) 0) - (prune (car args) - #'(lambda (arg) (try `(constantly ,arg)))))) - - ((funcall) - (try 0) - (let ((fn (second form)) - (fn-args (cddr form))) - (mapc try-fn fn-args) - (unless (equal fn '(constantly 0)) - (try `(funcall (constantly 0) ,@fn-args))) - (when (and (consp fn) - (eql (car fn) 'function) - (symbolp (cadr fn))) - (try `(,(cadr fn) ,@fn-args))) - (prune-list fn-args - #'prune - #'(lambda (args) - (try `(funcall ,fn ,@args)))))) - - ((reduce) - (try 0) - (let ((arg1 (car args)) - (arg2 (cadr args)) - (rest (cddr args))) - (when (and ;; (null (cddr args)) - (consp arg1) - (eql (car arg1) 'function)) - (let ((arg1.2 (cadr arg1))) - (when (and (consp arg1.2) - (eql (car arg1.2) 'lambda)) - (let ((largs (cadr arg1.2)) - (body (cddr arg1.2))) - (when (null (cdr body)) - (prune (car body) - #'(lambda (bform) - (try `(reduce (function (lambda ,largs ,bform)) - ,arg2 ,@rest))))))))) - (when (consp arg2) - (case (car arg2) - ((list vector) - (let ((arg2.rest (cdr arg2))) - (mapc try-fn arg2.rest) - (prune-list arg2.rest - #'prune - #'(lambda (args) - (try `(reduce ,arg1 - (,(car arg2) ,@args) - ,@rest)))))))))) - - ((apply) - (try 0) - (let ((fn (second form)) - (fn-args (butlast (cddr form))) - (list-arg (car (last form)))) - (mapc try-fn fn-args) - (unless (equal fn '(constantly 0)) - (try `(apply (constantly 0) ,@(cddr form)))) - (when (and (consp list-arg) - (eq (car list-arg) 'list)) - (mapc try-fn (cdr list-arg))) - (prune-list fn-args - #'prune - #'(lambda (args) - (try `(apply ,fn ,@args ,list-arg)))) - (when (and (consp list-arg) - (eq (car list-arg) 'list)) - (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) - (prune-list (cdr list-arg) - #'prune - #'(lambda (args) - (try `(apply ,fn ,@fn-args - (list ,@args)))))))) - - ((progv) - (try 0) - (prune-progv form try-fn)) - - ((tagbody) - (try 0) - (prune-tagbody form try-fn)) - - ((progn) - (when (null args) (try nil)) - (try (car (last args))) - (loop for i from 0 below (1- (length args)) - for a in args - do (try `(progn ,@(subseq args 0 i) - ,@(subseq args (1+ i)))) - do (when (and (consp a) - (or - (eq (car a) 'progn) - (and (eq (car a) 'tagbody) - (every #'consp (cdr a))))) - (try `(progn ,@(subseq args 0 i) - ,@(copy-list (cdr a)) - ,@(subseq args (1+ i)))))) - (prune-fn form try-fn)) - - ((loop) - (try 0) - (when (and (eql (length args) 6) - (eql (elt args 0) 'for) - (eql (elt args 2) 'below)) - (let ((var (elt args 1)) - (count (elt args 3)) - (form (elt args 5))) - (unless (eql count 0) (try count)) - (case (elt args 4) - (sum - (try `(let ((,(elt args 1) 0)) ,(elt args 5))) - (prune form #'(lambda (form) - (try `(loop for ,var below ,count sum ,form))))) - (count - (unless (or (eql form t) (eql form nil)) - (try `(loop for ,var below ,count count t)) - (try `(loop for ,var below ,count count nil)) - (prune form - #'(lambda (form) - (try `(loop for ,var below ,count count ,form)))))) - )))) - - (otherwise - (try 0) - (prune-fn form try-fn)) - - ))))) + (args (cdr form)) + (nargs (length args))) + (case op + + ((quote) nil) + + ((go) + (try 0)) + + ((signum integer-length logcount + logandc1 logandc2 lognand lognor logorc1 logorc2 + realpart imagpart) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((make-array) + (when (and (eq (car args) nil) + (eq (cadr args) ':initial-element) + ; (null (cdddr args)) + ) + (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args))))) + (when (cdddr args) + (try `(make-array nil :initial-element ,(caddr args)))) + )) + + ((cons) + (prune-fn form try-fn)) + + ((dotimes) + (try 0) + (let* ((binding-form (first args)) + (body (rest args)) + (var (first binding-form)) + (count-form (second binding-form)) + (result (third binding-form))) + (try result) + (unless (eql count-form 0) + (try `(dotimes (,var 0 ,result) ,@body))) + (prune result #'(lambda (form) + (try `(dotimes (,var ,count-form ,form) ,@body)))) + (when (= (length body) 1) + (prune (first body) + #'(lambda (form) + (when (consp form) + (try `(dotimes (,var ,count-form ,result) ,form)))))))) + + ((abs 1+ 1-) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((identity ignore-errors cl:handler-case restart-case locally) + (unless (and (consp args) + (consp (car args)) + (eql (caar args) 'tagbody)) + (mapc try-fn args)) + (prune-fn form try-fn)) + + ((boole) + (try (second args)) + (try (third args)) + (prune (second args) + #'(lambda (form) (try `(boole ,(first args) ,form ,(third args))))) + (prune (third args) + #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form))))) + + ((unwind-protect prog1 multiple-value-prog1) + (try (first args)) + (let ((val (first args)) + (rest (rest args))) + (when rest + (try `(unwind-protect ,val)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(unwind-protect ,val + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i)))))))) + (prune-fn form try-fn)) + + ((prog2) + (assert (>= (length args) 2)) + (let ((val1 (first args)) + (arg2 (second args)) + (rest (cddr args))) + (try arg2) + (prune-fn form try-fn) + (when rest + (try `(prog2 ,val1 ,arg2)) + (when (cdr rest) + (loop for i from 0 below (length rest) + do + (try `(prog2 ,val1 ,arg2 + ,@(subseq rest 0 i) + ,@(subseq rest (1+ i))))))))) + + ((typep) + (try (car args)) + (prune (car args) + #'(lambda (form) `(,op ,form ,@(cdr args))))) + + ((load-time-value) + (let ((arg (first args))) + (try arg) + (cond + ((cdr args) + (try `(load-time-value ,arg)) + (prune arg + #'(lambda (form) + (try `(load-time-value ,form ,(second args)))))) + (t + (prune arg + #'(lambda (form) + (try `(load-time-value ,form)))))))) + + ((eval) + (try 0) + (let ((arg (first args))) + (cond + ((consp arg) + (cond + ((eql (car arg) 'quote) + (prune (cadr arg) #'(lambda (form) (try `(eval ',form))))) + (t + (try arg) + (prune arg #'(lambda (form) `(eval ,form)))))) + (t (try arg))))) + + ((the macrolet cl:handler-bind restart-bind) + (assert (= (length args) 2)) + (try (second args)) + (prune (second args) try-fn)) + + ((not eq eql equal) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-fn form try-fn) + ) + + ((and or = < > <= >= /=) + (when (every #'constantp args) + (try (eval form))) + (try t) + (try nil) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((- + * min max logand logior logxor logeqv gcd lcm values) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (mapc try-fn args) + (prune-nary-fn form try-fn) + (prune-fn form try-fn)) + + ((/) + (when (every #'constantp args) + (try (eval form))) + (try 0) + (try (car args)) + (when (cddr args) + (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args))))))) + + ((expt rationalize rational numberator denominator) + (try 0) + (mapc try-fn args) + (prune-fn form try-fn)) + + ((coerce) + (try 0) + (try (car args)) + (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args)))))) + + + ((multiple-value-call) + ;; Simplify usual case + (when (= nargs 2) + (destructuring-bind (arg1 arg2) args + (when (and (consp arg1) (consp arg2) + (eql (first arg1) 'function) + (eql (first arg2) 'values)) + (mapc try-fn (rest arg2)) + (let ((fn (second arg1))) + (when (symbolp fn) + (try `(,fn ,@(rest arg2))))) + ;; Prune the VALUES form + (prune-list (rest arg2) + #'prune + #'(lambda (args) + (try `(multiple-value-call ,arg1 (values ,@args))))) + ))) + (mapc try-fn (rest args))) + + ((bit sbit elt aref svref) + (try 0) + (when (= (length args) 2) + (let ((arg1 (car args)) + (arg2 (cadr args))) + (when (and (consp arg2) + (eql (car arg2) 'min) + (integerp (cadr arg2))) + (let ((arg2.2 (caddr arg2))) + (try arg2.2) + (when (and (consp arg2.2) + (eql (car arg2.2) 'max) + (integerp (cadr arg2.2))) + (prune (caddr arg2.2) + #'(lambda (form) + (try `(,op ,arg1 (min ,(cadr arg2) + (max ,(cadr arg2.2) ,form)))))))))))) + + ((car cdr) + (try 0) + (try 1)) + + ((if) + (let (;; (pred (first args)) + (then (second args)) + (else (third args))) + (try then) + (try else) + (when (every #'constantp args) + (try (eval form))) + (prune-fn form try-fn))) + + ((incf decf) + (try 0) + (assert (member (length form) '(2 3))) + (try (first args)) + (when (> (length args) 1) + (try (second args)) + (try `(,op ,(first args))) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form))))))) + + ((setq setf shiftf) + (try 0) + ;; Assumes only one assignment + (assert (= (length form) 3)) + (try (first args)) + (try (second args)) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((rotatef) + (try 0) + (mapc try-fn (cdr form))) + + ((multiple-value-setq) + (try 0) + ;; Assumes only one assignment, and one variable + (assert (= (length form) 3)) + (assert (= (length (first args)) 1)) + (try `(setq ,(caar args) ,(cadr args))) + (unless (integerp (second args)) + (prune (second args) + #'(lambda (form) + (try `(,op ,(first args) ,form)))))) + + ((byte) + (prune-fn form try-fn)) + + ((deposit-field dpb) + (try 0) + (destructuring-bind (a1 a2 a3) + args + (try a1) + (try a3) + (when (and (integerp a1) + (integerp a3) + (and (consp a2) + (eq (first a2) 'byte) + (integerp (second a2)) + (integerp (third a2)))) + (try (eval form)))) + (prune-fn form try-fn)) + + ((ldb mask-field) + (try 0) + (try (second args)) + (when (and (consp (first args)) + (eq 'byte (first (first args))) + (every #'numberp (cdr (first args))) + (numberp (second args))) + (try (eval form))) + (prune-fn form try-fn)) + + ((ldb-test) + (try t) + (try nil) + (prune-fn form try-fn)) + + ((let let*) + (prune-let form try-fn)) + + ((multiple-value-bind) + (assert (= (length args) 3)) + (let ((arg1 (first args)) + (arg2 (second args)) + (body (caddr args))) + (when (= (length arg1) 1) + (try `(let ((,(first arg1) ,arg2)) ,body))) + (prune arg2 #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,form ,body)))) + (prune body #'(lambda (form) + (try `(multiple-value-bind ,arg1 ,arg2 ,form)))))) + + ((block) + (let ((name (second form)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the block entirely if it is not in use + (when (not (find-in-tree name body)) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block <n> (return-from <n> <e>)) + (when (and (consp form1) + (eq (first form1) 'return-from) + (eq (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(block ,name ,x)))))))) + + ((catch) + (let* ((tag (second form)) + (name (if (consp tag) (cadr tag) tag)) + (body (cddr form))) + (when (and body (null (cdr body))) + (let ((form1 (first body))) + + ;; Try removing the catch entirely if it is not in use + ;; We make assumptions here about what throws can + ;; be present. + (when (or (not (find-in-tree 'throw body)) + (not (find-in-tree name body))) + (try form1)) + + ;; Try removing the block if its only use is an immediately + ;; enclosed return-from: (block <n> (return-from <n> <e>)) + (when (and (consp form1) + (eq (first form1) 'throw) + (equal (second form1) name) + (not (find-in-tree name (third form1)))) + (try (third form1))) + + ;; Otherwise, try to simplify the subexpression + (prune form1 + #'(lambda (x) + (try `(catch ,tag ,x)))))))) + + ((throw) + (try (second args)) + (prune (second args) + #'(lambda (x) (try `(throw ,(first args) ,x))))) + + ((flet labels) + (try 0) + (prune-flet form try-fn)) + + ((case) + (prune-case form try-fn)) + + ((isqrt) + (let ((arg (second form))) + (assert (null (cddr form))) + (assert (consp arg)) + (assert (eq (first arg) 'abs)) + (let ((arg2 (second arg))) + (try arg2) + ;; Try to fold + (when (integerp arg2) + (try (isqrt (abs arg2)))) + ;; Otherwise, simplify arg2 + (prune arg2 #'(lambda (form) + (try `(isqrt (abs ,form)))))))) + + ((ash) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (try form2) + (prune form1 + #'(lambda (form) + (try `(ash ,form ,form2)))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (eq (first form2) 'min) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(ash ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((floor ceiling truncate round mod rem) + (try 0) + (let ((form1 (second form)) + (form2 (third form))) + (try form1) + (when (cddr form) (try form2)) + (prune form1 + (if (cddr form) + #'(lambda (form) + (try `(,op ,form ,form2))) + #'(lambda (form) (try `(,op ,form))))) + (when (and (consp form2) + (= (length form2) 3)) + (when (and (integerp form1) + (member (first form2) '(max min)) + (every #'integerp (cdr form2))) + (try (eval form))) + (let ((form3 (third form2))) + (prune form3 + #'(lambda (form) + (try + `(,op ,form1 (,(first form2) ,(second form2) + ,form))))))))) + + ((constantly) + (unless (eql (car args) 0) + (prune (car args) + #'(lambda (arg) (try `(constantly ,arg)))))) + + ((funcall) + (try 0) + (let ((fn (second form)) + (fn-args (cddr form))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(funcall (constantly 0) ,@fn-args))) + (when (and (consp fn) + (eql (car fn) 'function) + (symbolp (cadr fn))) + (try `(,(cadr fn) ,@fn-args))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(funcall ,fn ,@args)))))) + + ((reduce) + (try 0) + (let ((arg1 (car args)) + (arg2 (cadr args)) + (rest (cddr args))) + (when (and ;; (null (cddr args)) + (consp arg1) + (eql (car arg1) 'function)) + (let ((arg1.2 (cadr arg1))) + (when (and (consp arg1.2) + (eql (car arg1.2) 'lambda)) + (let ((largs (cadr arg1.2)) + (body (cddr arg1.2))) + (when (null (cdr body)) + (prune (car body) + #'(lambda (bform) + (try `(reduce (function (lambda ,largs ,bform)) + ,arg2 ,@rest))))))))) + (when (consp arg2) + (case (car arg2) + ((list vector) + (let ((arg2.rest (cdr arg2))) + (mapc try-fn arg2.rest) + (prune-list arg2.rest + #'prune + #'(lambda (args) + (try `(reduce ,arg1 + (,(car arg2) ,@args) + ,@rest)))))))))) + + ((apply) + (try 0) + (let ((fn (second form)) + (fn-args (butlast (cddr form))) + (list-arg (car (last form)))) + (mapc try-fn fn-args) + (unless (equal fn '(constantly 0)) + (try `(apply (constantly 0) ,@(cddr form)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (mapc try-fn (cdr list-arg))) + (prune-list fn-args + #'prune + #'(lambda (args) + (try `(apply ,fn ,@args ,list-arg)))) + (when (and (consp list-arg) + (eq (car list-arg) 'list)) + (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil)) + (prune-list (cdr list-arg) + #'prune + #'(lambda (args) + (try `(apply ,fn ,@fn-args + (list ,@args)))))))) + + ((progv) + (try 0) + (prune-progv form try-fn)) + + ((tagbody) + (try 0) + (prune-tagbody form try-fn)) + + ((progn) + (when (null args) (try nil)) + (try (car (last args))) + (loop for i from 0 below (1- (length args)) + for a in args + do (try `(progn ,@(subseq args 0 i) + ,@(subseq args (1+ i)))) + do (when (and (consp a) + (or + (eq (car a) 'progn) + (and (eq (car a) 'tagbody) + (every #'consp (cdr a))))) + (try `(progn ,@(subseq args 0 i) + ,@(copy-list (cdr a)) + ,@(subseq args (1+ i)))))) + (prune-fn form try-fn)) + + ((loop) + (try 0) + (when (and (eql (length args) 6) + (eql (elt args 0) 'for) + (eql (elt args 2) 'below)) + (let ((var (elt args 1)) + (count (elt args 3)) + (form (elt args 5))) + (unless (eql count 0) (try count)) + (case (elt args 4) + (sum + (try `(let ((,(elt args 1) 0)) ,(elt args 5))) + (prune form #'(lambda (form) + (try `(loop for ,var below ,count sum ,form))))) + (count + (unless (or (eql form t) (eql form nil)) + (try `(loop for ,var below ,count count t)) + (try `(loop for ,var below ,count count nil)) + (prune form + #'(lambda (form) + (try `(loop for ,var below ,count count ,form)))))) + )))) + + (otherwise + (try 0) + (prune-fn form try-fn)) + + ))))) (setf (gethash form *prune-table*) t) nil) @@ -2194,156 +2244,156 @@ "Return true if VALUE is eql to a node in TREE." (or (eql value tree) (and (consp tree) - (or (find-in-tree value (car tree)) - (find-in-tree value (cdr tree)))))) + (or (find-in-tree value (car tree)) + (find-in-tree value (cdr tree)))))) (defun prune-list (list element-prune-fn list-try-fn) (declare (type function element-prune-fn list-try-fn)) "Utility function for pruning in a list." (loop for i from 0 - for e in list - do (funcall element-prune-fn - e - #'(lambda (form) - (funcall list-try-fn - (append (subseq list 0 i) - (list form) - (subseq list (1+ i)))))))) + for e in list + do (funcall element-prune-fn + e + #'(lambda (form) + (funcall list-try-fn + (append (subseq list 0 i) + (list form) + (subseq list (1+ i)))))))) (defun prune-case (form try-fn) (declare (type function try-fn)) (flet ((try (e) (funcall try-fn e))) (let* ((op (first form)) - (expr (second form)) - (cases (cddr form))) + (expr (second form)) + (cases (cddr form))) ;; Try just the top expression (try expr) ;; Try simplifying the expr (prune expr - #'(lambda (form) - (try `(,op ,form ,@cases)))) + #'(lambda (form) + (try `(,op ,form ,@cases)))) ;; Try individual cases (loop for case in cases - do (try (first (last (rest case))))) + do (try (first (last (rest case))))) ;; Try deleting individual cases (loop for i from 0 below (1- (length cases)) - do (try `(,op ,expr - ,@(subseq cases 0 i) - ,@(subseq cases (1+ i))))) + do (try `(,op ,expr + ,@(subseq cases 0 i) + ,@(subseq cases (1+ i))))) ;; Try simplifying the cases ;; Assume each case has a single form (prune-list cases - #'(lambda (case try-fn) - (declare (type function try-fn)) - (when (and (listp (car case)) - (> (length (car case)) 1)) - ;; try removing constants - (loop for i below (length (car case)) - do (funcall try-fn - `((,@(subseq (car case) 0 i) - ,@(subseq (car case) (1+ i))) - ,@(cdr case))))) - (when (eql (length case) 2) - (prune (cadr case) - #'(lambda (form) - (funcall try-fn - (list (car case) form)))))) - #'(lambda (cases) - (try `(,op ,expr ,@cases))))))) + #'(lambda (case try-fn) + (declare (type function try-fn)) + (when (and (listp (car case)) + (> (length (car case)) 1)) + ;; try removing constants + (loop for i below (length (car case)) + do (funcall try-fn + `((,@(subseq (car case) 0 i) + ,@(subseq (car case) (1+ i))) + ,@(cdr case))))) + (when (eql (length case) 2) + (prune (cadr case) + #'(lambda (form) + (funcall try-fn + (list (car case) form)))))) + #'(lambda (cases) + (try `(,op ,expr ,@cases))))))) (defun prune-tagbody (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) - (body (cdr form))) + (body (cdr form))) (loop for i from 0 - for e in body - do - (cond - ((atom e) - ;; A tag - (unless (find-in-tree e (subseq body 0 i)) - (funcall try-fn `(tagbody ,@(subseq body 0 i) - ,@(subseq body (1+ i)))))) - (t - (funcall try-fn - `(tagbody ,@(subseq body 0 i) - ,@(subseq body (1+ i)))) - (prune e - #'(lambda (form) - ;; Don't put an atom here. - (when (consp form) - (funcall - try-fn - `(tagbody ,@(subseq body 0 i) - ,form - ,@(subseq body (1+ i)))))))))))) + for e in body + do + (cond + ((atom e) + ;; A tag + (unless (find-in-tree e (subseq body 0 i)) + (funcall try-fn `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))))) + (t + (funcall try-fn + `(tagbody ,@(subseq body 0 i) + ,@(subseq body (1+ i)))) + (prune e + #'(lambda (form) + ;; Don't put an atom here. + (when (consp form) + (funcall + try-fn + `(tagbody ,@(subseq body 0 i) + ,form + ,@(subseq body (1+ i)))))))))))) (defun prune-progv (form try-fn) (declare (type function try-fn)) (let (;; (op (car form)) - (vars-form (cadr form)) - (vals-form (caddr form)) - (body-list (cdddr form))) + (vars-form (cadr form)) + (vals-form (caddr form)) + (body-list (cdddr form))) (when (and (null vars-form) (null vals-form)) (funcall try-fn `(let () ,@body-list))) (when (and (consp vals-form) (eql (car vals-form) 'list)) (when (and (consp vars-form) (eql (car vars-form) 'quote)) - (let ((vars (cadr vars-form)) - (vals (cdr vals-form))) - (when (eql (length vars) (length vals)) - (let ((let-form `(let () ,@body-list))) - (mapc #'(lambda (var val) - (setq let-form `(let ((,var ,val)) ,let-form))) - vars vals) - (funcall try-fn let-form))) - ;; Try simplifying the vals forms - (prune-list vals - #'prune - #'(lambda (vals) - (funcall try-fn - `(progv ,vars-form (list ,@vals) ,@body-list))))))) + (let ((vars (cadr vars-form)) + (vals (cdr vals-form))) + (when (eql (length vars) (length vals)) + (let ((let-form `(let () ,@body-list))) + (mapc #'(lambda (var val) + (setq let-form `(let ((,var ,val)) ,let-form))) + vars vals) + (funcall try-fn let-form))) + ;; Try simplifying the vals forms + (prune-list vals + #'prune + #'(lambda (vals) + (funcall try-fn + `(progv ,vars-form (list ,@vals) ,@body-list))))))) ;; Try simplifying the body (when (eql (length body-list) 1) (prune (car body-list) - #'(lambda (form) - (funcall try-fn - `(progv ,vars-form ,vals-form ,form))))))) + #'(lambda (form) + (funcall try-fn + `(progv ,vars-form ,vals-form ,form))))))) (defun prune-nary-fn (form try-fn) ;; Attempt to reduce the number of arguments to the fn ;; Do not reduce below 1 (declare (type function try-fn)) (let* ((op (car form)) - (args (cdr form)) - (nargs (length args))) + (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))))))) + do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) + ,@(subseq args i))))))) (defun prune-fn (form try-fn) "Attempt to simplify a function call form. It is considered acceptable to replace the call by one of its argument forms." (declare (type function try-fn)) (prune-list (cdr form) - #'prune - #'(lambda (args) - (funcall try-fn (cons (car form) args))))) + #'prune + #'(lambda (args) + (funcall try-fn (cons (car form) args))))) (defun prune-let (form try-fn) "Attempt to simplify a LET form." (declare (type function try-fn)) (let* ((op (car form)) - (binding-list (cadr form)) - (body (cddr form)) - (body-len (length body)) - (len (length binding-list)) - ) + (binding-list (cadr form)) + (body (cddr form)) + (body-len (length body)) + (len (length binding-list)) + ) (when (> body-len 1) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) @@ -2351,95 +2401,95 @@ ;; Try to simplify (let ((<name> <form>)) ...) to <form> #| (when (and (>= len 1) - ;; (eql body-len 1) - ;; (eql (caar binding-list) (car body)) - ) + ;; (eql body-len 1) + ;; (eql (caar binding-list) (car body)) + ) (let ((val-form (cadar binding-list))) - (unless (and (consp val-form) - (eql (car val-form) 'make-array)) - (funcall try-fn val-form)))) + (unless (and (consp val-form) + (eql (car val-form) 'make-array)) + (funcall try-fn val-form)))) |# (when (>= len 1) (let ((val-form (cadar binding-list))) - (when (consp val-form) - (case (car val-form) - ((make-array) - (let ((init (getf (cddr val-form) :initial-element))) - (when init - (funcall try-fn init)))) - ((cons) - (funcall try-fn (cadr val-form)) - (funcall try-fn (caddr val-form))))))) + (when (consp val-form) + (case (car val-form) + ((make-array) + (let ((init (getf (cddr val-form) :initial-element))) + (when init + (funcall try-fn init)))) + ((cons) + (funcall try-fn (cadr val-form)) + (funcall try-fn (caddr val-form))))))) ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - (prune (cadr binding) - #'(lambda (form) - (funcall try-fn - (list (car binding) - form))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (prune (cadr binding) + #'(lambda (form) + (funcall try-fn + (list (car binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) ;; Prune off unused variable (when (and binding-list - (not (rest binding-list)) - (let ((name (caar binding-list))) - (and (symbolp name) - (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) + (not (rest binding-list)) + (let ((name (caar binding-list))) + (and (symbolp name) + (not (find-if-subtree #'(lambda (x) (eq x name)) body))))) (funcall try-fn `(progn ,@body))) ;; Try to simplify the body of the LET form (when body (unless binding-list - (funcall try-fn (car (last body)))) + (funcall try-fn (car (last body)))) (when (and (first binding-list) - (not (rest binding-list)) - (not (rest body))) - (let ((binding (first binding-list))) - (unless (or (consp (second binding)) - (has-binding-to-var (first binding) body) - (has-assignment-to-var (first binding) body) - ) - (funcall try-fn `(let () - ,@(subst (second binding) - (first binding) - (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) - body) - )))))) + (not (rest binding-list)) + (not (rest body))) + (let ((binding (first binding-list))) + (unless (or (consp (second binding)) + (has-binding-to-var (first binding) body) + (has-assignment-to-var (first binding) body) + ) + (funcall try-fn `(let () + ,@(subst (second binding) + (first binding) + (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare))) + body) + )))))) (prune (car (last body)) - #'(lambda (form2) - (funcall try-fn - `(,@(butlast form) ,form2))))))) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) (defun has-assignment-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) - (or - (and (member (car form) '(setq setf shiftf incf decf) :test #'eq) - (eq (cadr form) var)) - (and (eql (car form) 'multiple-value-setq) - (member var (cadr form)))))) + (or + (and (member (car form) '(setq setf shiftf incf decf) :test #'eq) + (eq (cadr form) var)) + (and (eql (car form) 'multiple-value-setq) + (member var (cadr form)))))) form)) (defun has-binding-to-var (var form) (find-if-subtree #'(lambda (form) (and (consp form) - (case (car form) - ((let let*) - (loop for binding in (cadr form) - thereis (eq (car binding) var))) - ((progv) - (and (consp (cadr form)) - (eq (caadr form) 'quote) - (consp (second (cadr form))) - (member var (second (cadr form))))) - (t nil)))) + (case (car form) + ((let let*) + (loop for binding in (cadr form) + thereis (eq (car binding) var))) + ((progv) + (and (consp (cadr form)) + (eq (caadr form) 'quote) + (consp (second (cadr form))) + (member var (second (cadr form))))) + (t nil)))) form)) (defun find-if-subtree (pred tree) @@ -2448,7 +2498,7 @@ ((funcall pred tree) tree) ((consp tree) (or (find-if-subtree pred (car tree)) - (find-if-subtree pred (cdr tree)))) + (find-if-subtree pred (cdr tree)))) (t nil))) (defun prune-flet (form try-fn) @@ -2456,90 +2506,90 @@ (declare (type function try-fn)) (let* ((op (car form)) - (binding-list (cadr form)) - (body (cddr form))) + (binding-list (cadr form)) + (body (cddr form))) ;; Remove a declaration, if any (when (and (consp body) - (consp (car body)) - (eq (caar body) 'declare)) + (consp (car body)) + (eq (caar body) 'declare)) (funcall try-fn `(,op ,binding-list ,@(cdr body)))) ;; Try to prune optional arguments (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - (let* ((name (car binding)) - (args (cadr binding)) - (body (cddr binding)) - (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) - (the list args)))) - (when opt-pos - (incf opt-pos) - (let ((normal-args (subseq args 0 (1- opt-pos))) - (optionals (subseq args opt-pos))) - (prune-list optionals - #'(lambda (opt-lambda-arg try-fn) - (declare (type function try-fn)) - (when (consp opt-lambda-arg) - (let ((name (first opt-lambda-arg)) - (form (second opt-lambda-arg))) - (prune form - #'(lambda (form) - (funcall try-fn (list name form))))))) - #'(lambda (opt-args) - (funcall try-fn - `(,name (,@normal-args - &optional - ,@opt-args) - ,@body)))))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) - + #'(lambda (binding try-fn) + (declare (type function try-fn)) + (let* ((name (car binding)) + (args (cadr binding)) + (body (cddr binding)) + (opt-pos (position-if #'(lambda (e) (member e '(&key &optional))) + (the list args)))) + (when opt-pos + (incf opt-pos) + (let ((normal-args (subseq args 0 (1- opt-pos))) + (optionals (subseq args opt-pos))) + (prune-list optionals + #'(lambda (opt-lambda-arg try-fn) + (declare (type function try-fn)) + (when (consp opt-lambda-arg) + (let ((name (first opt-lambda-arg)) + (form (second opt-lambda-arg))) + (prune form + #'(lambda (form) + (funcall try-fn (list name form))))))) + #'(lambda (opt-args) + (funcall try-fn + `(,name (,@normal-args + &optional + ,@opt-args) + ,@body)))))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) + ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list - #'(lambda (binding try-fn) - (declare (type function try-fn)) - - ;; Prune body of a binding - (prune (third binding) - #'(lambda (form) - (funcall try-fn - (list (first binding) - (second binding) - form))))) - #'(lambda (bindings) - (funcall try-fn `(,op ,bindings ,@body)))) + #'(lambda (binding try-fn) + (declare (type function try-fn)) + + ;; Prune body of a binding + (prune (third binding) + #'(lambda (form) + (funcall try-fn + (list (first binding) + (second binding) + form))))) + #'(lambda (bindings) + (funcall try-fn `(,op ,bindings ,@body)))) ;; ;; Try to simplify the body of the FLET form (when body ;; No bindings -- try to simplify to the last form in the body (unless binding-list - (funcall try-fn (first (last body)))) + (funcall try-fn (first (last body)))) (when (and (consp binding-list) - (null (rest binding-list))) - (let ((binding (first binding-list))) - ;; One binding -- match on (flet ((<name> () <body>)) (<name>)) - (when (and (symbolp (first binding)) - (not (find-in-tree (first binding) (rest binding))) - (null (second binding)) - (equal body (list (list (first binding))))) - (funcall try-fn `(,op () ,@(cddr binding)))) - ;; One binding -- try to remove it if not used - (when (and (symbolp (first binding)) - (not (find-in-tree (first binding) body))) - (funcall try-fn (first (last body)))) - )) + (null (rest binding-list))) + (let ((binding (first binding-list))) + ;; One binding -- match on (flet ((<name> () <body>)) (<name>)) + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) (rest binding))) + (null (second binding)) + (equal body (list (list (first binding))))) + (funcall try-fn `(,op () ,@(cddr binding)))) + ;; One binding -- try to remove it if not used + (when (and (symbolp (first binding)) + (not (find-in-tree (first binding) body))) + (funcall try-fn (first (last body)))) + )) ;; Try to simplify (the last form in) the body. (prune (first (last body)) - #'(lambda (form2) - (funcall try-fn - `(,@(butlast form) ,form2))))))) + #'(lambda (form2) + (funcall try-fn + `(,@(butlast form) ,form2))))))) ;;; Routine to walk form, applying a function at each form ;;; The fn is applied in preorder. When it returns :stop, do @@ -2551,55 +2601,55 @@ (unless (eq (funcall fn form) :stop) (when (consp form) (let ((op (car form))) - (case op - ((let let*) - (walk-let form fn)) - ((cond) - (dolist (clause (cdr form)) - (walk-implicit-progn clause fn))) - ((multiple-value-bind) - (walk (third form) fn) - (walk-body (cdddr form) fn)) - ((function quote declare) nil) - ((block the return-from) - (walk-implicit-progn (cddr form) fn)) - ((case typecase) - (walk (cadr form) fn) - (dolist (clause (cddr form)) - (walk-implicit-progn (cdr clause) fn))) - ((flet labels) - - - - + (case op + ((let let*) + (walk-let form fn)) + ((cond) + (dolist (clause (cdr form)) + (walk-implicit-progn clause fn))) + ((multiple-value-bind) + (walk (third form) fn) + (walk-body (cdddr form) fn)) + ((function quote declare) nil) + ((block the return-from) + (walk-implicit-progn (cddr form) fn)) + ((case typecase) + (walk (cadr form) fn) + (dolist (clause (cddr form)) + (walk-implicit-progn (cdr clause) fn))) + ((flet labels) + + + + |# ;;;;;;;;;;;;;;;;;;;;;; ;;; Convert pruned results to test cases (defun produce-test-cases (instances &key - (stream *standard-output*) - (prefix "MISC.") - (index 1)) + (stream *standard-output*) + (prefix "MISC.") + (index 1)) (dolist (inst instances) (let* (;; (vars (getf inst :vars)) - (vals (getf inst :vals)) - (optimized-lambda-form (getf inst :optimized-lambda-form)) - (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) - (name (intern - (concatenate 'string prefix (format nil "~D" index)) - "CL-TEST")) - (test-form - `(deftest ,name - (let* ((fn1 ',optimized-lambda-form) - (fn2 ',unoptimized-lambda-form) - (vals ',vals) - (v1 (apply (compile nil fn1) vals)) - (v2 (apply (compile nil fn2) vals))) - (if (eql v1 v2) - :good - (list v1 v2))) - :good))) + (vals (getf inst :vals)) + (optimized-lambda-form (getf inst :optimized-lambda-form)) + (unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) + (name (intern + (concatenate 'string prefix (format nil "~D" index)) + "CL-TEST")) + (test-form + `(deftest ,name + (let* ((fn1 ',optimized-lambda-form) + (fn2 ',unoptimized-lambda-form) + (vals ',vals) + (v1 (apply (compile nil fn1) vals)) + (v2 (apply (compile nil fn2) vals))) + (if (eql v1 v2) + :good + (list v1 v2))) + :good))) (print test-form stream) (terpri stream) (incf index))) diff --git a/ansi-tests/random-type-prop-tests-08.lsp b/ansi-tests/random-type-prop-tests-08.lsp index e2d4d708e0e6f8428ef0868e865c68d010e5db55..3b2c38c99f25eb3987cd8d048e6d3bbe8ae4c8f1 100644 --- a/ansi-tests/random-type-prop-tests-08.lsp +++ b/ansi-tests/random-type-prop-tests-08.lsp @@ -187,14 +187,12 @@ bit-vector-p simple-bit-vector-p))) `(member ,@funs ,@(mapcar #'symbol-function funs))) '(or list vector) - '(eql :test) - (let ((test-funs '(eq eql equal equalp))) - `(member ,@test-funs ,@(mapcar #'symbol-function test-funs)))) + '(eql :key) + (let ((key-funs '(identity not null))) + `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) 4) - - ;;; Put count-if-not tests here @@ -270,4 +268,3 @@ (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) - diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index 815341a263c2adc0f0b176495e79e321b0840e75..918f0f1d33e3807323382d28a2a2b52ae5b8e39d 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -12,11 +12,8 @@ (defvar *print-random-type-prop-input* nil) (defparameter *random-type-prop-result* nil) -(defgeneric make-random-type-containing (val) - (:method-combination randomized) - (:documentation "Given a value, generate a random type that contains that value.")) - (declaim (special *param-types* *params* *is-var?* *form*)) +(declaim (special *replicate-type*)) (defparameter *default-reps* 1000) (defparameter *default-cell* nil) @@ -105,7 +102,7 @@ (cell *default-cell*) (ignore *default-ignore*) (test #'regression-test::equalp-with-case) - (replicate nil)) + (replicate nil replicate-p)) (assert (<= 1 minargs maxargs 20)) (prog1 (dotimes (i reps) @@ -122,6 +119,8 @@ (make-list (max 0 (- nargs (length arg-types))) :initial-element rest-type)) 0 nargs)) + (replicate (if replicate-p replicate + (mapcar (constantly nil) types))) ; (vals (mapcar #'make-random-element-of-type types)) (vals (setq *params* (or (make-random-arguments types) (go again)))) @@ -138,7 +137,7 @@ (params (loop for x in is-var? for p in param-names when x collect p)) - (param-types (mapcar #'make-random-type-containing vals)) + (param-types (mapcar #'make-random-type-containing vals replicate)) (*param-types* param-types) (type-decls (loop for x in is-var? for p in param-names @@ -159,10 +158,11 @@ t)) (expr `(,operator ,@(loop for x in is-var? for v in vals + for r in replicate for p in param-names collect (if x (if (and arg-the (coin)) - (let ((tp (make-random-type-containing v))) + (let ((tp (make-random-type-containing v r))) `(the ,tp ,p)) p) (if (or (consp v) @@ -239,19 +239,33 @@ #'(lambda (body) `(defmethod ,name ,@body)) bodies))) -(defmethods make-random-type-containing +(defgeneric make-random-type-containing* (val) + (:method-combination randomized) + (:documentation "Produce a random type containing VAL. If the special +variable *REPLICATE-TYPE* is true, and the value is mutable, then do not +use the value in MEMBER or EQL type specifiers.")) + +(defun make-random-type-containing (type &optional *replicate-type*) + (declare (special *replicate-type*)) + (make-random-type-containing* type)) + +(defmethods make-random-type-containing* (4 ((val t)) + (declare (special *replicate-type*)) (rcase (1 t) (1 (if (consp val) 'cons 'atom)) - (1 `(eql ,val)) - (1 (let* ((n1 (random 4)) + (1 (if *replicate-type* (make-random-type-containing* val) + `(eql ,val))) + (1 + (if *replicate-type* (make-random-type-containing* val) + (let* ((n1 (random 4)) (n2 (random 4)) ;; Replace these calls with (make-random-element-of-type t) ;; at some point (l1 (loop repeat n1 collect (random-leaf))) (l2 (loop repeat n2 collect (random-leaf)))) - `(member ,@l1 ,val ,@l2))))) + `(member ,@l1 ,val ,@l2)))))) (1 ((val standard-object)) 'standard-object) (1 ((val class)) 'class) @@ -349,7 +363,7 @@ (rcase (1 '*) (1 dim)))) ;;; More methods -(defmethods make-random-type-containing +(defmethods make-random-type-containing* (3 ((val bit-vector)) (let ((root (if (and (coin) (typep val 'simple-bit-vector)) @@ -406,13 +420,13 @@ (1 ((val cons)) (rcase (1 'cons) - (2 `(cons ,(make-random-type-containing (car val)) - ,(make-random-type-containing (cdr val)))) - (1 `(cons ,(make-random-type-containing (car val)) + (2 `(cons ,(make-random-type-containing* (car val)) + ,(make-random-type-containing* (cdr val)))) + (1 `(cons ,(make-random-type-containing* (car val)) ,(random-from-seq #(t *)))) - (1 `(cons ,(make-random-type-containing (car val)))) + (1 `(cons ,(make-random-type-containing* (car val)))) (1 `(cons ,(random-from-seq #(t *)) - ,(make-random-type-containing (cdr val)) + ,(make-random-type-containing* (cdr val)) )))) (1 ((val complex)) @@ -465,8 +479,8 @@ (1 `(vector ,element-type ,length)) (1 (make-list-type length 'null element-type)))) -(defun make-random-sequence-type-containing (element) - (make-sequence-type (random 10) (make-random-type-containing element))) +(defun make-random-sequence-type-containing (element &optional *replicate-type*) + (make-sequence-type (random 10) (make-random-type-containing* element))) (defun same-set-p (set1 set2 &rest args &key key test test-not) (declare (ignorable key test test-not)) diff --git a/ansi-tests/random-types.lsp b/ansi-tests/random-types.lsp index b1d6b8231fe4ff53242db6e2152edbd06280252b..d8f25e842ac03201c8414a3d45b89df717b25261 100644 --- a/ansi-tests/random-types.lsp +++ b/ansi-tests/random-types.lsp @@ -174,9 +174,10 @@ collect (list t1 t2) finally (terpri))) -(defun test-random-mutated-types (n size) +(defun test-random-mutated-types (n size &key (reps 1)) (loop for t1 = (make-random-type size) - for t2 = (mutate-type t1) + 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)) @@ -184,7 +185,7 @@ (format t "~A " i) (finish-output *standard-output*)) when (test-types t1 t2) collect (list t1 t2) - finally (terpri))) + finally (terpri))) (defun test-types (t1 t2) (multiple-value-bind (sub success)