From 8f5636083e82ae203fee5f60c586a7c6118384cb Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Mon, 24 May 2004 09:13:37 +0000
Subject: [PATCH] Tweaked the pruner for make-array forms

---
 ansi-tests/random-int-form.lsp | 215 +++++++++++++++++++++++++--------
 1 file changed, 163 insertions(+), 52 deletions(-)

diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp
index 0ae8bd6a..fb4ba4ec 100644
--- a/ansi-tests/random-int-form.lsp
+++ b/ansi-tests/random-int-form.lsp
@@ -104,8 +104,8 @@
 (defvar *print-immediately* nil)
 
 (defvar *compile-unoptimized-form*
-  #-(or gcl clisp armedbear) t
-  #+(or gcl clisp armedbear) nil)
+  #+(or allegro sbcl) t
+  #-(or allegro sbcl) nil)
 
 (declaim (special *vars*))
 
@@ -114,9 +114,13 @@
   (type t))
 
 (defun test-random-integer-forms
-  (size nvars n &key ((:random-state *random-state*) (make-random-state t))
+  (size nvars n
+	&key ((:random-state *random-state*) (make-random-state t))
 	(file-prefix "b")
-	(index 0))
+	(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
@@ -137,7 +141,8 @@
 	     ;; #+sbcl (sb-ext::gc :full t)
 	     (prin1 i) (princ " ") (finish-output *standard-output*))
 	nconc (let ((result (test-random-integer-form
-			     size nvars
+			     (if random-size (1+ (random size)) size)
+			     (if random-nvars (1+ (random nvars)) nvars)
 			     :index (+ index i)
 			     :file-prefix file-prefix)))
 		(when result
@@ -147,10 +152,10 @@
 		result)))
 
 (defun test-random-integer-form
-  (size nvars &key (index 0) (file-prefix "b")
-	&aux (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)))
-  (let* ((var-ranges (mapcar #'make-random-integer-range vars))
+  (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)))
@@ -249,6 +254,14 @@
   (let ((r (ash 1 (1+ (random 32)))))
     (- (random r) (floor (/ r 2)))))
 
+(defun random-var-desc ()
+  (loop
+   (let* ((pos (random (length *vars*)))
+	  (desc (elt *vars* pos)))
+     (when (= pos (position (var-desc-name desc) (the list *vars*)
+			    :key #'var-desc-name))
+       (return desc)))))
+
 (defun make-random-integer-form (size)
   "Generate a random legal lisp form of size SIZE (roughly)."
   
@@ -258,7 +271,17 @@
        when
        (rcase
 	(10 (make-random-integer))
-	(9 (if *vars* (var-desc-name (random-from-seq *vars*))
+	(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 nil)) `(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*
@@ -588,15 +611,35 @@
 	  `(eval (values ,@args))))
      )))
 
+(defun make-random-type-for-var (var e1)
+  (let (desc)
+    (values
+     (cond
+      ((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq)
+	    (setq desc (find var *vars* :key #'var-desc-name)))
+       (var-desc-type desc))
+      (t (rcase
+	  (4 '(integer * *))
+	  (2 (setq e1 `(make-array nil :initial-element ,e1
+				   ,@(rcase (1 nil) (1 '(:adjustable t)))))
+	     '(array integer nil))
+	  (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 make-random-integer-binding-form (size)
   (destructuring-bind (s1 s2) (random-partition (1- size) 2)
     (let* ((var (rcase
 		 (2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
-		 (2 (random-from-seq #(*s1* *s2* *s3* *s4*
-					    *s5* *s6* *s7* *s8*)))))
+		 (2 (random-from-seq #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)))))
 	   (e1 (make-random-integer-form s1))
-	   (e2 (let ((*vars* (cons (make-var-desc :name var
-						  :type '(integer * *))
+	   (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*))))
@@ -604,18 +647,24 @@
       (if (member var *vars* :key #'var-desc-name)
 	  (make-random-integer-form size)
 	(rcase
-	 (8 `(,op ((,var ,e1)) ,e2))
+	 (8 `(,op ((,var ,e1))
+		  ,@(rcase (1 `((declare (dynamic-extent ,var))))
+			   (1 nil))
+		  ,e2))
 	 (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
 
 (defun make-random-integer-progv-form (size)
   (let* ((num-vars (random 4))
-	 (possible-vars #(*s1* *s2* *s3* *s4*
-			       *s5* *s6* *s7* *s8*))
+	 (possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))
 	 (vars nil))
     (loop repeat num-vars
 	  do (loop for r = (elt possible-vars (random (length possible-vars)))
 		   while (member r vars)
 		   finally (push r vars)))
+    (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name)))
+					    (and desc (not (subtypep (var-desc-type desc) 'integer)))))
+			  vars)
+	  num-vars (length vars))
     (if (null vars)
 	`(progv nil nil ,(make-random-integer-form (1- size)))
       (destructuring-bind (s1 s2) (random-partition (1- size) 2)
@@ -676,20 +725,27 @@
 	     (var (var-desc-name vdesc))
 	     (type (var-desc-type vdesc))
 	     (op (random-from-seq #(setq setf #-(or armedbear)shiftf))))
-	(rcase
-	 (3 nil)
-	 (1 (setq op 'multiple-value-setq)
-	    (setq var (list var))))
 	(cond
-	 ((equal type '(integer * *))
+	 ((subtypep '(integer * *) type)
 	  (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
+	  (when (coin 4)
+	    (setq op 'multiple-value-setq)
+	    (setq var (list var)))
 	  `(,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))))
+	  (when (coin 4)
+	    (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))
+	  (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))))
 	 ;; Abort -- can't assign
 	 (t (make-random-integer-form size))))
     (make-random-integer-form size)))
@@ -735,20 +791,27 @@
 		      (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))))
+			      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)))
+	     )
 	(destructuring-bind (s1 s2 . opt-sizes)
-	    (random-partition (1- size) (+ 2 (- maxargs minargs)))
+	    (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))
 	  (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 arg-names
+			(*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)
+		 (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)))
@@ -757,10 +820,26 @@
 				  &optional
 				  ,@(mapcar #'list
 					    (subseq arg-names minargs)
-					    opt-forms))
+					    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 ,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))
@@ -1127,6 +1206,16 @@
 	  (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)))))))
+
+	 ((cons)
+	  (prune-fn form try-fn))
+
 	 ((dotimes)
 	  (try 0)
 	  (let* ((binding-form (first args))
@@ -1287,20 +1376,24 @@
 
 	 ((bit sbit elt aref svref)
 	  (try 0)
-	  (assert (= (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)))
-		(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)))))))))))
+	  (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)))
+		  (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))
@@ -1778,14 +1871,20 @@
 	 (binding-list (cadr form))
 	 (body (cddr form))
 	 ;; (body-len (length body))
-	 (len (length binding-list)))
+	 ;; (len (length binding-list))
+	 )
 
     ;; Try to simplify (let ((<name> <form>)) ...) to <form>
+    #|
     (when (and (>= len 1)
 	       ;; (eql body-len 1)
 	       ;; (eql (caar binding-list) (car body))
 	       )
-      (funcall try-fn (cadar binding-list)))
+      (let ((val-form (cadar binding-list)))
+	(unless (and (consp val-form)
+		     (eql (car val-form) 'make-array))
+	  (funcall try-fn val-form))))
+    |#
 
     ;; Try to simplify the forms in the RHS of the bindings
     (prune-list binding-list
@@ -1809,10 +1908,14 @@
 	(let ((binding (first binding-list)))
 	  (unless (or (consp (second binding))
 		      (has-binding-to-var (first binding) body)
-		      (has-assignment-to-var (first binding) body))
+		      (has-assignment-to-var (first binding) body)
+		      )
 	    (funcall try-fn `(let ()
 			       ,@(subst (second binding)
-					(first binding) body))))))
+					(first binding)
+					(remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
+						   body)
+					))))))
       (prune (car (last body))
 	     #'(lambda (form2)
 		 (funcall try-fn
@@ -1862,6 +1965,12 @@
 	 (binding-list (cadr form))
 	 (body (cddr form)))
 
+    ;; Remove a declaration, if any
+    (when (and (consp body)
+	       (consp (car body))
+	       (eq (caar body) 'declare))
+      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
+
     ;; Try to prune optional arguments
     (prune-list binding-list
 		#'(lambda (binding try-fn)
@@ -1869,7 +1978,8 @@
 		    (let* ((name (car binding))
 			   (args (cadr binding))
 			   (body (cddr binding))
-			   (opt-pos (position '&optional (the list args))))
+			   (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)))
@@ -1877,11 +1987,12 @@
 			  (prune-list optionals
 				      #'(lambda (opt-lambda-arg try-fn)
 					  (declare (type function try-fn))
-					  (let ((name (first opt-lambda-arg))
-						(form (second opt-lambda-arg)))
-					    (prune form
-						   #'(lambda (form)
-						       (funcall try-fn (list name form))))))
+					  (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
-- 
GitLab