From 96ad237dd42a66b5fc8490c80e74758971f230ce Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sat, 12 Jun 2004 18:07:53 +0000
Subject: [PATCH] Improve pruner, and make the AREF forms work properly in ACL
 where there's a subtypep bug on zero-rank array types.

---
 ansi-tests/random-int-form.lsp | 120 +++++++++++++++++++++++++++++++--
 1 file changed, 114 insertions(+), 6 deletions(-)

diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp
index 01049082..ab336c4f 100644
--- a/ansi-tests/random-int-form.lsp
+++ b/ansi-tests/random-int-form.lsp
@@ -62,6 +62,11 @@
 
 (defun p (i) (write (elt $y i) :pretty t :escape t) (values))
 
+(defun load-failures (&key (pathname "failures.lsp"))
+  (length (setq $y (with-open-file (s pathname :direction :input)
+				   (loop for x = (read s nil)
+					 while x collect x)))))
+
 (defun tn (n &optional (size 100))
   (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n))))))
 
@@ -262,6 +267,17 @@
 			    :key #'var-desc-name))
        (return desc)))))
 
+(defun is-zero-rank-integer-array-type (type)
+  "This function was introduced because of a bug in ACL 6.2"
+  ; (subtypep type '(array integer 0))
+  (and (consp type)
+       (eq (car type) 'array)
+       (cddr type)
+       (or (eq (cadr type) '*)
+	   (subtypep (cadr type) 'integer))
+       (or (eql (caddr type) 0)
+	   (null (caddr type)))))
+
 (defun make-random-integer-form (size)
   "Generate a random legal lisp form of size SIZE (roughly)."
   
@@ -277,7 +293,9 @@
 		      (name (var-desc-name desc)))
 		 (cond
 		  ((subtypep type 'integer) name)
-		  ((subtypep type '(array integer nil)) `(aref ,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))))
@@ -297,11 +315,14 @@
        return it)
     ;; (> size 1)
     (rcase
+
      ;; flet call
      #-(or armedbear)
      (30 ;; 5
       (make-random-integer-flet-call-form size))
 
+     (5 (make-random-aref-form size))
+
      ;; Unary ops
      (40
       (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate
@@ -489,7 +510,6 @@
 	     (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
 	`(block ,name ,(make-random-integer-form (1- size)))))
 
-     #-(or armedbear)
      (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*)))
@@ -553,6 +573,27 @@
 
      )))
 
+(defun make-random-aref-form (size)
+  (or
+   (when *vars*
+     (let* ((desc (random-var-desc))
+	    (type (var-desc-type desc))
+	    (name (var-desc-name desc)))
+       (cond
+	((null type) nil)
+	((subtypep type '(array integer (*)))
+	 `(aref ,name (min ,(1- (first (third type)))
+			   (max 0 ,(make-random-integer-form (- size 2))))))
+	((subtypep type '(array integer (* *)))
+	 (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
+	   `(aref ,name
+		  (min ,(1- (first (third type)))
+		       (max 0 ,(make-random-integer-form s1)))
+		  (min ,(1- (second (third type)))
+		       (max 0 ,(make-random-integer-form s2))))))
+	(t nil))))
+   (make-random-integer-form size)))
+
 (defun make-random-integer-flet-call-form (size)
   (if *flet-names*
       (let* ((flet-entry (random-from-seq *flet-names*))
@@ -620,9 +661,20 @@
        (var-desc-type desc))
       (t (rcase
 	  (4 '(integer * *))
-	  (2 (setq e1 `(make-array nil :initial-element ,e1
+	  (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))
@@ -741,11 +793,31 @@
 	    (setq op 'multiple-value-setq)
 	    (setq var (list var)))
 	  `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
-	 ((and (subtypep '(array integer nil) 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)))
@@ -1358,6 +1430,18 @@
 	  (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 #'(lambda (form) (try `(coerce ,form ,(cadr args))))
+		 (car args)))
+	  
+
 	 ((multiple-value-call)
 	  ;; Simplify usual case
 	  (when (= nargs 2)
@@ -1386,6 +1470,7 @@
 			 (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)))
@@ -1873,10 +1958,13 @@
   (let* ((op (car form))
 	 (binding-list (cadr form))
 	 (body (cddr form))
-	 ;; (body-len (length body))
-	 ;; (len (length binding-list))
+	 (body-len (length body))
+	 (len (length binding-list))
 	 )
 
+    (when (> body-len 1)
+      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
+
     ;; Try to simplify (let ((<name> <form>)) ...) to <form>
     #|
     (when (and (>= len 1)
@@ -1889,6 +1977,18 @@
 	  (funcall try-fn val-form))))
     |#
 
+    (when (>= len 1)
+      (let ((val-form (cadar binding-list)))
+	(when (consp val-form)
+	  (case (car val-form)
+	    ((make-array)
+	     (let ((init (getf (cddr val-form) :initial-element)))
+	       (when init
+		 (funcall try-fn init))))
+	    ((cons)
+	     (funcall try-fn (cadr val-form))
+	     (funcall try-fn (caddr val-form)))))))
+
     ;; Try to simplify the forms in the RHS of the bindings
     (prune-list binding-list
 		#'(lambda (binding try-fn)
@@ -1901,6 +2001,14 @@
 		#'(lambda (bindings)
 		    (funcall try-fn `(,op ,bindings ,@body))))
 
+    ;; Prune off unused variable
+    (when (and binding-list
+	       (not (rest binding-list))
+	       (let ((name (caar binding-list)))
+		 (and (symbolp name)
+		      (not (find-if-subtree #'(lambda (x) (eq x name)) body)))))
+      (funcall try-fn `(progn ,@body)))
+
     ;; Try to simplify the body of the LET form
     (when body
       (unless binding-list
-- 
GitLab