source: trunk/source/tests/ansi-tests/random-int-form.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 114.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Wed Sep 10 18:03:52 2003
4;;;; Contains: Simple randon form generator/tester
5
6(in-package :cl-test)
7
8(compile-and-load "random-aux.lsp")
9
10;;;
11;;; This file contains a routine for generating random legal Common Lisp functions
12;;; for differential testing.
13;;;
14;;; To run the random tests by themselves, start a lisp in the ansi-tests directory
15;;; and do the following:
16;;;   (load "gclload1.lsp")
17;;;   (compile-and-load "random-int-form.lsp")
18;;;   (in-package :cl-test)
19;;;   (let ((*random-state* (make-random-state t)))
20;;;      (test-random-integer-forms 100 4 10000)) ;; or other parameters
21;;;
22;;; If a test breaks during testing the variables *optimized-fn-src*,
23;;; *unoptimized-fn-src*, and *int-form-vals* can be used to get the source
24;;; of the optimized/unoptimized lambda forms being compiled, and the arguments
25;;; on which they are called.
26;;;
27;;; If a difference is found between optimized/unoptimized functions the forms,
28;;; values, and results are collected.  A list of all these discrepancies is returned
29;;; after testing finishes (assuming nothing breaks).
30;;;
31;;; The variable *compile-unoptimized-form* controls whether the low optimization
32;;; form is compiled, or if a form funcalling it is EVALed.  The latter is often
33;;; faster, and may find more problems since an interpreter and compiler may evaluate
34;;; forms in very different ways.
35;;;
36;;; The rctest/ subdirectory contains fragments of a more OO random form generator
37;;; that will eventually replace this preliminary effort.
38;;;
39;;; The file misc.lsp contains tests that were mostly for bugs found by this
40;;; random tester in various Common Lisp implementations.
41;;;
42
43(declaim (special *optimized-fn-src* *unoptimized-fn-src* *int-form-vals*
44                  *opt-result* *unopt-result* $x $y $z
45                  *compile-unoptimized-form*
46                  *make-random-integer-form-cdf*))
47
48;;; Little functions used to run collected tests.
49;;; (f i) runs the ith collected optimized test
50;;; (g i) runs the ith collected unoptimized test
51;;; (p i) prints the ith test (forms, input values, and other information)
52
53(defun f (i) (let ((plist (elt $y i)))
54               (apply (compile nil (getf plist :optimized-lambda-form))
55                      (getf plist :vals))))
56
57(defun g (i) (let ((plist (elt $y i)))
58               (if *compile-unoptimized-form*
59                   (apply (compile nil (getf plist :unoptimized-lambda-form))
60                          (getf plist :vals))
61                 (apply (the function (eval `(function ,(getf plist :unoptimized-lambda-form))))
62                        (getf plist :vals)))))
63
64(defun p (i) (write (elt $y i) :pretty t :escape t) (values))
65
66(defun load-failures (&key (pathname "failures.lsp"))
67  (length (setq $y (with-open-file (s pathname :direction :input)
68                                   (loop for x = (read s nil)
69                                         while x collect x)))))
70
71(defun tn (n &optional (size 100))
72  (length (setq $y (prune-results (setq $x (test-random-integer-forms size 2 n))))))
73
74(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
75
76(defparameter *random-special-vars*
77  #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
78
79(defparameter *loop-random-int-form-period* 2000)
80
81(defmacro cl-handler-bind (&rest args)
82  `(cl:handler-bind ,@args))
83
84(defmacro cl-handler-case (&rest args)
85  `(cl:handler-case ,@args))
86
87(eval-when
88 (:compile-toplevel :load-toplevel :execute)
89 (defun cumulate (vec)
90   (loop for i from 1 below (length vec)
91         do (incf (aref vec i) (aref vec (1- i))))
92   vec))
93
94(defparameter *default-make-random-integer-form-cdf*
95  (cumulate (copy-seq #(10 5 40 4 5 4 2 2 10 1 1 #-armedbead 1 #-armedbear 1
96                       #-allegro 5 5 5 #-(or gcl ecl armedbear) 2
97                       2 #-(or cmu allegro poplog) 5 4 30
98                       4 20 3 2 2 1 1 5 30 #-poplog 5
99                       #-(or allegro poplog) 10
100                       50 4 4 10 20 10 10 3
101                       20 5 #-(or armedbear) 20
102                       2 2 2))))
103
104(defparameter *make-random-integer-form-cdf*
105  (copy-seq *default-make-random-integer-form-cdf*))
106
107(eval-when
108 (:compile-toplevel :load-toplevel :execute)
109 (defmacro with-random-integer-form-params (&body forms)
110   (let ((len (gensym "LEN"))
111         (vec (gensym "VEC")))
112     `(let* ((,len (length *default-make-random-integer-form-cdf*))
113             (,vec (make-array ,len)))
114        (loop for i from 0 below ,len do (setf (aref ,vec i)
115                                               (1+ (min (random 100)
116                                                        (random 100)))))
117        (setq ,vec (cumulate ,vec))
118        (let ((*make-random-integer-form-cdf* ,vec))
119          ,@forms)))))
120
121;;; Run the random tester, collecting failures into the special
122;;; variable $y.
123
124(defun loop-random-int-forms (&optional (size 200) (nvars 3))
125  (unless (boundp '$x) (setq $x nil))
126  (unless (boundp '$y) (setq $y nil))
127  (loop
128   for i from 1
129   do
130   (format t "~6D | " i)
131   (finish-output *standard-output*)
132   (let ((x (test-random-integer-forms
133             size nvars *loop-random-int-form-period*
134             :index (* (1- i) *loop-random-int-form-period*))))
135     (when x
136       (setq $x (append $x x))
137       (setq x (prune-results x))
138       (terpri) (print x) (finish-output *standard-output*)
139       (setq $y (append $y x)))
140     (terpri))))
141
142(defvar *random-int-form-blocks* nil)
143(defvar *random-int-form-catch-tags* nil)
144(defvar *go-tags* nil)
145
146(defvar *random-vals-list-bound* 10)
147
148(defvar *max-compile-time* 0)
149(defvar *max-compile-term* nil)
150
151(defvar *print-immediately* nil)
152
153(defvar *compile-unoptimized-form*
154  #+(or allegro sbcl) t
155  #-(or allegro sbcl) nil)
156
157(declaim (special *vars*))
158
159(defstruct var-desc
160  (name nil :type symbol)
161  (type t))
162
163(defun test-random-integer-forms
164  (size nvars n
165        &key ((:random-state *random-state*) (make-random-state t))
166        (file-prefix "b")
167        (index 0)
168        (random-size nil)
169        (random-nvars nil)
170        )
171
172  "Generate random integer forms of size SIZE with NVARS variables.
173   Do this N times, returning all those on which a discrepancy
174   is found between optimized and nonoptimize, notinlined code."
175
176  (assert (integerp nvars))
177  (assert (<= 1 nvars 26))
178  (assert (and (integerp n) (plusp n)))
179  (assert (and (integerp n) (plusp size)))
180
181  (loop for i from 1 to n
182        do (when (= (mod i 100) 0)
183              ;; #+sbcl (print "Do gc...")
184              ;; #+sbcl (sb-ext::gc :full t)
185              ;; #+lispworks-personal-edition (cl-user::normal-gc)
186              (prin1 i) (princ " ") (finish-output *standard-output*))
187         nconc (let ((result (test-random-integer-form
188                              (if random-size (1+ (random size)) size)
189                              (if random-nvars (1+ (random nvars)) nvars)
190                              :index (+ index i)
191                              :file-prefix file-prefix)))
192                 (when result
193                   (let ((*print-readably* nil))
194                     (format t "~%~A~%" (format nil "~S" (car result)))
195                     (finish-output *standard-output*)))
196                 result)))
197
198(defun test-random-integer-form
199  (size nvars &key (index 0) (file-prefix "b"))
200  (let* ((vars (subseq '(a b c d e f g h i j k l m
201                           n o p q r s u v w x y z) 0 nvars))
202         (var-ranges (mapcar #'make-random-integer-range vars))
203         (var-types (mapcar #'(lambda (range)
204                                (let ((lo (car range))
205                                      (hi (cadr range)))
206                                  (assert (>= hi lo))
207                                  `(integer ,lo ,hi)))
208                            var-ranges))
209         (form (let ((*vars* (loop for v in vars
210                                   for tp in var-types
211                                   collect (make-var-desc :name v
212                                                          :type tp)))
213                     (*random-int-form-blocks* nil)
214                     (*random-int-form-catch-tags* nil)
215                     (*go-tags* nil)
216                     )
217                 (with-random-integer-form-params
218                  (make-random-integer-form (1+ (random size))))))
219         (vals-list
220          (loop repeat *random-vals-list-bound*
221                collect
222                (mapcar #'(lambda (range)
223                            (let ((lo (car range))
224                                  (hi (cadr range)))
225                              (random-from-interval (1+ hi) lo)))
226                        var-ranges)))
227         (opt-decls-1 (make-random-optimize-settings))
228         (opt-decls-2 (make-random-optimize-settings)))
229    (when *print-immediately*
230      (with-open-file
231       (s (format nil "~A~A.lsp" file-prefix index)
232          :direction :output :if-exists :error)
233       (print `(defparameter *x*
234                 '(:vars ,vars
235                      :var-types ,var-types
236                      :vals-list ,vals-list
237                      :decls1 ,opt-decls-1
238                      :decls2 ,opt-decls-2
239                      :form ,form))
240              s)
241       (print '(load "c.lsp") s)
242       (finish-output s))
243       ;; (cl-user::gc)
244       ;; (make-list 1000000)
245      )
246    (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2)))
247
248(defun make-random-optimize-settings ()
249  (loop for settings = (list*
250                        (list 'speed (random 4))
251                        #+sbcl '(sb-c:insert-step-conditions 0)
252                        (loop for s in '(space safety debug compilation-speed)
253                              for n = (random 4)
254                              collect (list s n)))
255        while
256        #+allegro (subsetp '((speed 3) (safety 0)) settings :test 'equal)
257        #-allegro nil
258        finally (return (random-permute settings))))
259
260(defun fn-symbols-in-form (form)
261  "Return a list of the distinct standardized lisp function
262   symbols occuring ing FORM.  These are used to generate a NOTINLINE
263   declaration for the unoptimized form."
264  (intersection
265   (remove-duplicates (fn-symbols-in-form* form) :test #'eq)
266   *cl-function-or-accessor-symbols*))
267
268(defun fn-symbols-in-form* (form)
269  (when (consp form)
270    (if (symbolp (car form))
271        (cons (car form) (mapcan #'fn-symbols-in-form* (cdr form)))
272      (mapcan #'fn-symbols-in-form* form))))
273
274(defun fn-arg-name (fn-name arg-index)
275  (intern (concatenate 'string
276                       (subseq (symbol-name fn-name) 1)
277                       (format nil "-~D" arg-index))
278          (symbol-package fn-name)))                       
279
280(declaim (special *flet-names*))
281(defparameter *flet-names* nil)
282
283
284
285(defun random-var-desc ()
286  (loop
287   (let* ((pos (random (length *vars*)))
288          (desc (elt *vars* pos)))
289     (when (= pos (position (var-desc-name desc) (the list *vars*)
290                            :key #'var-desc-name))
291       (return desc)))))
292
293(defun is-zero-rank-integer-array-type (type)
294  "This function was introduced because of a bug in ACL 6.2"
295  ; (subtypep type '(array integer 0))
296  (and (consp type)
297       (eq (car type) 'array)
298       (cddr type)
299       (or (eq (cadr type) '*)
300           (subtypep (cadr type) 'integer))
301       (or (eql (caddr type) 0)
302           (null (caddr type)))))
303
304(defun make-random-integer-form (size)
305  "Generate a random legal lisp form of size SIZE (roughly)."
306
307  (if (<= size 1)
308      ;; Leaf node -- generate a variable, constant, or flet function call
309      (loop
310       when
311       (rcase
312        (10 (make-random-integer))
313        (9 (if *vars*
314               (let* ((desc (random-var-desc))
315                      (type (var-desc-type desc))
316                      (name (var-desc-name desc)))
317                 (cond
318                  ((subtypep type 'integer) name)
319                  (; (subtypep type '(array integer 0))
320                   (is-zero-rank-integer-array-type type)
321                   `(aref ,name))
322                  ((subtypep type '(cons integer integer))
323                   (rcase (1 `(car ,name))
324                          (1 `(cdr ,name))))
325                  (t nil)))
326             nil))
327        (1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil))
328        (2 (if *flet-names*
329               (let* ((flet-entry (random-from-seq *flet-names*))
330                      (flet-name (car flet-entry))
331                      (flet-minargs (cadr flet-entry))
332                      (flet-maxargs (caddr flet-entry))
333                      (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
334                      (args (loop repeat nargs
335                                  collect (make-random-integer-form 1))))
336                 `(,flet-name ,@args))
337             nil)))
338       return it)
339    ;; (> size 1)
340    (rselect *make-random-integer-form-cdf*
341
342     ;; flet call
343     (make-random-integer-flet-call-form size)
344     (make-random-aref-form size)
345     ;; Unary ops
346     (let ((op (random-from-seq '(- abs signum 1+ 1- conjugate
347                                     rational rationalize
348                                     numerator denominator
349                                     identity progn floor
350                                     ;; #-(or armedbear)
351                                     ignore-errors
352                                     cl:handler-case
353                                     restart-case
354                                     ceiling truncate round realpart imagpart
355                                     integer-length logcount values
356                                     locally))))
357        `(,op ,(make-random-integer-form (1- size))))
358
359     (make-random-integer-unwind-protect-form size)
360     (make-random-integer-mapping-form size)
361
362     ;; prog1, multiple-value-prog1
363     (let* ((op (random-from-seq #(prog1 multiple-value-prog1)))
364            (nforms (random 4))
365            (sizes (random-partition (1- size) (1+ nforms)))
366            (args (mapcar #'make-random-integer-form sizes)))
367       `(,op ,@args))
368
369     ;; prog2
370     (let* ((nforms (random 4))
371            (sizes (random-partition (1- size) (+ nforms 2)))
372            (args (mapcar #'make-random-integer-form sizes)))
373       `(prog2 ,@args))
374     
375     `(isqrt (abs ,(make-random-integer-form (- size 2))))
376
377     `(the integer ,(make-random-integer-form (1- size)))
378     
379     `(cl:handler-bind nil ,(make-random-integer-form (1- size)))
380     `(restart-bind nil ,(make-random-integer-form (1- size)))
381     #-armedbear
382     `(macrolet () ,(make-random-integer-form (1- size)))
383     #-armedbear
384     `(symbol-macrolet () ,(make-random-integer-form (1- size)))
385
386     ;; dotimes
387     #-allegro
388     (let* ((var (random-from-seq #(iv1 iv2 iv3 iv4)))
389            (count (random 4))
390            (sizes (random-partition (1- size) 2))
391            (body (let ((*vars* (cons (make-var-desc :name var :type nil)
392                                      *vars*)))
393                    (make-random-integer-form (first sizes))))
394            (ret-form (make-random-integer-form (second sizes))))
395       (unless (consp body) (setq body `(progn ,body)))
396       `(dotimes (,var ,count ,ret-form) ,body))
397
398     ;; loop
399     (make-random-loop-form (1- size))
400
401     (make-random-count-form size)
402
403     #-(or gcl ecl armedbear)
404     ;; load-time-value
405     (let ((arg (let ((*flet-names* nil)
406                      (*vars* nil)
407                      (*random-int-form-blocks* nil)
408                      (*random-int-form-catch-tags* nil)
409                      (*go-tags* nil))
410                  (make-random-integer-form (1- size)))))
411       (rcase
412        (4 `(load-time-value ,arg t))
413        (2 `(load-time-value ,arg))
414        (2 `(load-time-value ,arg nil))))
415
416     ;; eval
417     (make-random-integer-eval-form size)
418     
419     #-(or cmu allegro poplog)
420     (destructuring-bind (s1 s2)
421        (random-partition (- size 2) 2)
422        `(ash ,(make-random-integer-form s1)
423              (min ,(random 100)
424                   ,(make-random-integer-form s2))))
425     
426     ;; binary floor, ceiling, truncate, round
427     (let ((op (random-from-seq #(floor ceiling truncate round mod rem)))
428           (op2 (random-from-seq #(max min))))
429       (destructuring-bind (s1 s2)
430          (random-partition (- size 2) 2)
431          `(,op  ,(make-random-integer-form s1)
432                 (,op2  ,(if (eq op2 'max)
433                             (1+ (random 100))
434                           (- (1+ (random 100))))
435                        ,(make-random-integer-form s2)))))
436           
437     ;; Binary op
438     (let* ((op (random-from-seq
439                  '(+ - *  logand min max gcd
440                      lcm
441                      #-:allegro
442                      logandc1
443                      logandc2 logeqv logior lognand lognor
444                      #-:allegro
445                      logorc1
446                      logorc2
447                      logxor
448                      ))))
449        (destructuring-bind (leftsize rightsize)
450            (random-partition (1- size) 2)
451          (let ((e1 (make-random-integer-form leftsize))
452                (e2 (make-random-integer-form rightsize)))
453            `(,op ,e1 ,e2))))
454
455     ;; boole
456     (let* ((op (random-from-seq
457                  #(boole-1 boole-2 boole-and boole-andc1 boole-andc2
458                    boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand
459                    boole-nor boole-orc1 boole-orc2 boole-set boole-xor))))
460        (destructuring-bind (leftsize rightsize)
461            (random-partition (- size 2) 2)
462          (let ((e1 (make-random-integer-form leftsize))
463                (e2 (make-random-integer-form rightsize)))
464            `(boole ,op ,e1 ,e2))))
465
466     ;; n-ary ops
467     (let* ((op (random-from-seq #(+ - * logand min max
468                                      logior values lcm gcd logxor)))
469             (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
470             (nargs (1+ (min (random nmax) (random nmax))))
471             (sizes (random-partition (1- size) nargs))
472             (args (mapcar #'make-random-integer-form sizes)))
473        `(,op ,@args))
474
475     ;; expt
476     `(expt ,(make-random-integer-form (1- size)) ,(random 3))
477
478     ;; coerce
479     `(coerce ,(make-random-integer-form (1- size)) 'integer)
480     
481     ;; complex (degenerate case)
482     `(complex ,(make-random-integer-form (1- size)) 0)
483
484     ;; quotient (degenerate cases)
485     `(/ ,(make-random-integer-form (1- size)) 1)
486     `(/ ,(make-random-integer-form (1- size)) -1)
487
488     ;; tagbody
489     (make-random-tagbody-and-progn size)
490
491     ;; conditionals
492     (let* ((cond-size (random (max 1 (floor size 2))))
493            (then-size (random (- size cond-size)))
494            (else-size (- size 1 cond-size then-size))
495            (pred (make-random-pred-form cond-size))
496            (then-part (make-random-integer-form then-size))
497            (else-part (make-random-integer-form else-size)))
498       `(if ,pred ,then-part ,else-part))
499     #-poplog
500      (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
501        `(,(random-from-seq '(deposit-field dpb))
502          ,(make-random-integer-form s1)
503          ,(make-random-byte-spec-form s2)
504          ,(make-random-integer-form s3)))
505
506     #-(or allegro poplog)
507      (destructuring-bind (s1 s2) (random-partition (1- size) 2)
508          `(,(random-from-seq '(ldb mask-field))
509            ,(make-random-byte-spec-form s1)
510            ,(make-random-integer-form s2)))
511
512     (make-random-integer-binding-form size)
513
514     ;; progv
515     (make-random-integer-progv-form size)
516     
517     `(let () ,(make-random-integer-form (1- size)))
518
519      (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8)))
520             (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
521        `(block ,name ,(make-random-integer-form (1- size))))
522
523      (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8))))
524             (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
525        `(catch ,tag ,(make-random-integer-form (1- size))))
526     
527      ;; setq and similar
528      (make-random-integer-setq-form size)
529
530      (make-random-integer-case-form size)
531
532      (if *random-int-form-blocks*
533          (let ((name (random-from-seq *random-int-form-blocks*))
534                (form (make-random-integer-form (1- size))))
535            `(return-from ,name ,form))
536        ;; No blocks -- try again
537        (make-random-integer-form size))
538
539      (if *random-int-form-catch-tags*
540          (let ((tag (random-from-seq *random-int-form-catch-tags*))
541                (form (make-random-integer-form (1- size))))
542            `(throw ,tag ,form))
543        ;; No catch tags -- try again
544        (make-random-integer-form size))
545
546      (if *random-int-form-blocks*
547          (destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
548            (let ((name (random-from-seq *random-int-form-blocks*))
549                  (pred (make-random-pred-form s1))
550                  (then (make-random-integer-form s2))
551                  (else (make-random-integer-form s3)))
552              `(if ,pred (return-from ,name ,then) ,else)))
553        ;; No blocks -- try again
554        (make-random-integer-form size))
555
556     #-(or armedbear)
557     (make-random-flet-form size)
558
559      (let* ((nbits (1+ (min (random 20) (random 20))))
560             (bvec (coerce (loop repeat nbits collect (random 2)) 'simple-bit-vector))
561             (op (random-from-seq #(bit sbit))))
562        `(,op ,bvec (min ,(1- nbits) (max 0 ,(make-random-integer-form (- size 3 nbits))))))
563
564      (let* ((nvals (1+ (min (random 20) (random 20))))
565             (lim (ash 1 (+ 3 (random 40))))
566             (vec (coerce (loop repeat nvals collect (random lim)) 'simple-vector))
567             (op (random-from-seq #(aref svref elt))))
568        `(,op ,vec (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))
569
570      (let* ((nvals (1+ (min (random 20) (random 20))))
571             (lim (ash 1 (+ 3 (random 40))))
572             (vals (loop repeat nvals collect (random lim)))
573             (op 'elt))
574        `(,op ',vals (min ,(1- nvals) (max 0 ,(make-random-integer-form (- size 3 nvals))))))
575
576     )))
577
578(defun make-random-aref-form (size)
579  (or
580   (when *vars*
581     (let* ((desc (random-var-desc))
582            (type (var-desc-type desc))
583            (name (var-desc-name desc)))
584       (cond
585        ((null type) nil)
586        ((subtypep type '(array integer (*)))
587         `(aref ,name (min ,(1- (first (third type)))
588                           (max 0 ,(make-random-integer-form (- size 2))))))
589        ((subtypep type '(array integer (* *)))
590         (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
591           `(aref ,name
592                  (min ,(1- (first (third type)))
593                       (max 0 ,(make-random-integer-form s1)))
594                  (min ,(1- (second (third type)))
595                       (max 0 ,(make-random-integer-form s2))))))
596        (t nil))))
597   (make-random-integer-form size)))
598
599(defun make-random-count-form (size)
600  (destructuring-bind (s1 s2)
601      (random-partition (1- size) 2)
602    (let ((arg1 (make-random-integer-form s1))
603          (arg2-args (loop repeat s2 collect (make-random-integer))))
604      (let ((op 'count)
605            (test (random-from-seq #(eql = /= < > <= >=)))
606            (arg2 (rcase
607                   (1 (make-array (list s2) :initial-contents arg2-args))
608                   (1
609                    (let* ((mask (1- (ash 1 (1+ (random 32))))))
610                      (make-array (list s2)
611                                  :initial-contents
612                                  (mapcar #'(lambda (x) (logand x mask)) arg2-args)
613                                  :element-type `(integer 0 ,mask))))
614                   (1 `(quote ,arg2-args)))))
615        `(,op ,arg1 ,arg2 ,@(rcase
616                                    (2 nil)
617                                    (1 (list :test `(quote ,test)))
618                                    (1 (list :test-not `(quote ,test)))))))))
619
620(defun make-random-integer-flet-call-form (size)
621  (if *flet-names*
622      (let* ((flet-entry (random-from-seq *flet-names*))
623             (flet-name (car flet-entry))
624             (flet-minargs (cadr flet-entry))
625             (flet-maxargs (caddr flet-entry))
626             (nargs (random-from-interval (1+ flet-maxargs) flet-minargs))
627             )
628        (cond
629         ((> nargs 0)
630          (let* ((arg-sizes (random-partition (1- size) nargs))
631                 (args (mapcar #'make-random-integer-form arg-sizes)))
632            (rcase
633             (1 `(,flet-name ,@args))
634             (1 `(multiple-value-call #',flet-name (values ,@args)))
635             (1 `(funcall (function ,flet-name) ,@args))
636             (1 (let ((r (random (1+ (length args)))))
637                  `(apply (function ,flet-name)
638                          ,@(subseq args 0 r)
639                          (list ,@(subseq args r))))))))
640         (t (make-random-integer-form size))))
641    (make-random-integer-form size)))
642
643(defun make-random-integer-unwind-protect-form (size)
644  (let* ((op 'unwind-protect)
645         (nforms (random 4))
646         (sizes (random-partition (1- size) (1+ nforms)))
647         (arg (make-random-integer-form (first sizes)))
648         (unwind-forms
649          ;; We have to be careful not to generate code that will
650          ;; illegally transfer control to a dead location
651          (let ((*flet-names* nil)
652                (*go-tags* nil)
653                (*random-int-form-blocks* nil)
654                (*random-int-form-catch-tags* nil))
655            (mapcar #'make-random-integer-form (rest sizes)))))
656    `(,op ,arg ,@unwind-forms)))
657
658(defun make-random-integer-eval-form (size)
659  (flet ((%arg (size)
660               (let ((*flet-names* nil)
661                     (*vars* (remove-if-not #'(lambda (s)
662                                                (find (var-desc-name s)
663                                                      *random-special-vars*))
664                                            *vars*))
665                     (*random-int-form-blocks* nil)
666                     (*go-tags* nil))
667                 (make-random-integer-form size))))
668    (rcase
669     (2 `(eval ',(%arg (1- size))))
670     (2 (let* ((nargs (1+ (random 4)))
671               (sizes (random-partition (1- size) nargs))
672               (args (mapcar #'%arg sizes)))
673          `(eval (values ,@args))))
674     )))
675
676(defun make-random-type-for-var (var e1)
677  (let (desc)
678    (values
679     (cond
680      ((and (find var *random-special-vars*)
681            (setq desc (find var *vars* :key #'var-desc-name)))
682       (var-desc-type desc))
683      (t (rcase
684          (4 '(integer * *))
685          (1 (setq e1 `(make-array nil :initial-element ,e1
686                                   ,@(rcase (1 nil) (1 '(:adjustable t)))))
687             '(array integer nil))
688          (1 (let ((size (1+ (random 10))))
689               (setq e1 `(make-array '(,size):initial-element ,e1
690                                     ,@(rcase (1 nil) (1 '(:adjustable t)))))
691               `(array integer (,size))))
692          #|
693          (1 (let ((size1 (1+ (random 10)))
694                   (size2 (1+ (random 10))))
695               (setq e1 `(make-array '(,size1 ,size2):initial-element ,e1
696                                     ,@(rcase (1 nil) (1 '(:adjustable t)))))
697               `(array integer (,size1 ,size2))))
698          |#
699          (1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
700             '(cons integer integer))
701          (1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
702             '(cons integer integer)))))
703     e1)))
704
705(defun random2 (n)
706  (min (random n) (random n)))
707
708(defun random-from-seq2 (seq)
709  (elt seq (random2 (length seq))))
710
711(defun make-random-integer-binding-form (size)
712  (destructuring-bind (s1 s2) (random-partition (1- size) 2)
713    (let* ((var (random-from-seq2 (rcase
714                                   (2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))
715                                   #-ecl (2 *random-special-vars*)
716                                   )))
717           (e1 (make-random-integer-form s1))
718           (type (multiple-value-bind (type2 e)
719                     (make-random-type-for-var var e1)
720                   (setq e1 e)
721                   type2))
722           (e2 (let ((*vars* (cons (make-var-desc :name var :type type)
723                                   *vars*)))
724                 (make-random-integer-form s2)))
725           (op (random-from-seq #(let let*))))
726      ;; for now, avoid shadowing
727      (if (member var *vars* :key #'var-desc-name)
728          (make-random-integer-form size)
729        (rcase
730         (8 `(,op ((,var ,e1))
731                  ,@(rcase (1 `((declare (dynamic-extent ,var))))
732                           (3 nil))
733                  ,e2))
734         (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
735
736(defun make-random-integer-progv-form (size)
737  (let* ((num-vars (random 4))
738         (possible-vars *random-special-vars*)
739         (vars nil))
740    (loop repeat num-vars
741          do (loop for r = (elt possible-vars (random (length possible-vars)))
742                   while (member r vars)
743                   finally (push r vars)))
744    (setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name)))
745                                            (and desc (not (subtypep (var-desc-type desc) 'integer)))))
746                          vars)
747          num-vars (length vars))
748    (if (null vars)
749        `(progv nil nil ,(make-random-integer-form (1- size)))
750      (destructuring-bind (s1 s2) (random-partition (1- size) 2)
751        (let* ((var-sizes (random-partition s1 num-vars))
752               (var-forms (mapcar #'make-random-integer-form var-sizes))
753               (*vars* (append (loop for v in vars collect
754                                     (make-var-desc :name v :type '(integer * *)))
755                               *vars*))
756               (body-form (make-random-integer-form s2)))
757          `(progv ',vars (list ,@var-forms) ,body-form))))))
758
759(defun make-random-integer-mapping-form (size)
760  ;; reduce
761  (let ((keyargs nil)
762        (nargs (1+ (random (min 10 (max 1 size)))))
763        (sequence-op (random-from-seq '(vector list))))
764    (when (coin 2) (setq keyargs '(:from-end t)))
765    (cond
766     ((coin 2)
767      (let ((start (random nargs)))
768        (setq keyargs `(:start ,start ,@keyargs))
769        (when (coin 2)
770          (let ((end (+ start 1 (random (- nargs start)))))
771            (setq keyargs `(:end ,end ,@keyargs))))))
772     (t
773      (when (coin 2)
774        (let ((end (1+ (random nargs))))
775          (setq keyargs `(:end ,end ,@keyargs))))))
776    (rcase
777     (1
778      (let ((sizes (random-partition (1- size) nargs))
779            (op (random-from-seq #(+ - * logand logxor logior max min))))
780        `(reduce ,(rcase (1 `(function ,op))
781                         (1 `(quote ,op)))
782                 (,sequence-op
783                  ,@(mapcar #'make-random-integer-form sizes))
784                 ,@keyargs)))
785     #-(or armedbear)
786     (1     
787      (destructuring-bind (size1 size2) (random-partition (1- size) 2)
788        (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
789               (var1 (random-from-seq vars))
790               (var2 (random-from-seq (remove var1 vars)))
791               (form (let ((*vars* (list*
792                                    (make-var-desc :name var1 :type '(integer * *))
793                                    (make-var-desc :name var2 :type '(integer * *))
794                                    *vars*)))
795                       (make-random-integer-form size1)))
796               (sizes (random-partition size2 nargs))
797               (args (mapcar #'make-random-integer-form sizes)))
798          `(reduce (function (lambda (,var1 ,var2) ,form))
799                   (,sequence-op ,@args)
800                   ,@keyargs)))))))
801
802(defun make-random-integer-setq-form (size)
803  (if *vars*
804      (let* ((vdesc (random-from-seq *vars*))
805             (var (var-desc-name vdesc))
806             (type (var-desc-type vdesc))
807             (op (random-from-seq #(setq setf shiftf))))
808        (cond
809         ((subtypep '(integer * *) type)
810          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
811          (rcase
812           (1 (when (find var *random-special-vars*)
813                (setq op (random-from-seq #(setf shiftf))
814                      var `(symbol-value ',var))))
815           (1 (setq op 'multiple-value-setq)
816              (setq var (list var)))
817           (5 (setf op (random-from-seq #(setq setf shiftf incf decf)))))
818          `(,op ,var ,(make-random-integer-form (1- size))))
819         ((and (consp type)
820               (eq (car type) 'integer)
821               (integerp (second type))
822               (integerp (third type)))
823          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
824          (rcase
825           (1 (when (find var *random-special-vars*)
826                (setq op (random-from-seq #(setf shiftf))
827                      var `(symbol-value ',var))))
828           (1 (setq op 'multiple-value-setq)
829              (setq var (list var)))
830           (5 nil))
831          `(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
832         ((and type (is-zero-rank-integer-array-type type)) ; (subtypep type '(array integer nil))
833          (assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
834          (when (eq op 'setq)
835            (setq op (random-from-seq #(setf shiftf))))
836          `(,op (aref ,var) ,(make-random-integer-form (- size 2))))
837         ((and type (subtypep type '(array integer (*))))
838          (when (eq op 'setq)
839            (setq op (random-from-seq #(setf shiftf))))
840          (destructuring-bind (s1 s2) (random-partition (max 2 (- size 2)) 2)
841            `(,op (aref ,var (min ,(1- (first (third type)))
842                                  (max 0
843                                       ,(make-random-integer-form s1))))
844                  ,(make-random-integer-form s2))))
845         ((and type (subtypep type '(array integer (* *))))
846          (when (eq op 'setq)
847            (setq op (random-from-seq #(setf shiftf))))
848          (destructuring-bind (s1 s2 s3) (random-partition (max 3 (- size 3)) 3)
849            `(,op (aref ,var
850                        (min ,(1- (first (third type)))
851                             (max 0
852                                  ,(make-random-integer-form s1)))
853                        (min ,(1- (second (third type)))
854                             (max 0
855                                  ,(make-random-integer-form s2))))
856                  ,(make-random-integer-form s3))))
857         ;; Abort -- can't assign
858         (t (make-random-integer-form size))))
859    (make-random-integer-form size)))
860
861
862(defun make-random-integer-case-form (size)
863  (let ((ncases (1+ (random 10))))
864    (if (< (+ size size) (+ ncases 2))
865        ;; Too small, give up
866        (make-random-integer-form size)
867      (let* ((sizes (random-partition (1- size) (+ ncases 2)))
868             (bound (ash 1 (+ 2 (random 16))))
869             (lower-bound (if (coin 3) 0 (- bound)))
870             (upper-bound (if (and (< lower-bound 0) (coin 3))
871                              1
872                            (1+ bound)))
873             (cases
874              (loop
875               for case-size in (cddr sizes)
876               for vals = (loop repeat (1+ (min (random 10) (random 10)))
877                                collect (random-from-interval
878                                         upper-bound lower-bound))
879               for result = (make-random-integer-form case-size)
880               repeat ncases
881               collect `(,vals ,result)))
882             (expr (make-random-integer-form (first sizes))))
883        `(case ,expr
884           ,@cases
885           (t ,(make-random-integer-form (second sizes))))))))
886
887(defun make-random-flet-form (size)
888  "Generate random flet, labels forms, for now with no arguments
889   and a single binding per form."
890  (let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10
891                                  %f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18))))
892    (if (assoc fname *flet-names*)
893        ;; Fail if the name is in use
894        (make-random-integer-form size)
895      (let* ((op (random-from-seq #(flet labels)))
896             (minargs (random 4))
897             (maxargs #+:allegro minargs
898                      #-:allegro
899                      (rcase
900                       (1 minargs)
901                       (1 (+ minargs (random 4)))))
902             (keyarg-p (coin 2))
903             (keyarg-n (if keyarg-p (random 3) 0))
904             (arg-names (loop for i from 1 to maxargs
905                              collect (fn-arg-name fname i)))
906             (key-arg-names (loop for i from 1 to keyarg-n
907                                  collect (intern (format nil "KEY~A" i)
908                                                  (find-package "CL-TEST"))))
909             (allow-other-keys (and keyarg-p (coin 3)))
910             )
911        (let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))))
912               (s1 (car sizes))
913               (s2 (cadr sizes))
914               (opt-sizes (cddr sizes)))
915          (let* ((form1
916                  ;; Allow return-from of the flet/labels function
917                  (let ((*random-int-form-blocks*
918                         (cons fname *random-int-form-blocks*))
919                        (*vars* (nconc (loop for var in (append arg-names key-arg-names)
920                                             collect (make-var-desc :name var
921                                                                    :type '(integer * *)))
922                                       *vars*)))
923                    (make-random-integer-form s1)))
924                 (form2 (let ((*flet-names* (cons (list fname minargs maxargs keyarg-p)
925                                                  *flet-names*)))
926                          (make-random-integer-form s2)))
927                 (opt-forms (mapcar #'make-random-integer-form opt-sizes)
928                            ))
929            (if opt-forms
930                `(,op ((,fname (,@(subseq arg-names 0 minargs)
931                                  &optional
932                                  ,@(mapcar #'list
933                                            (subseq arg-names minargs)
934                                            opt-forms)
935                                  ,@(when keyarg-p
936                                      (append '(&key)
937                                              (mapcar #'list
938                                                      key-arg-names
939                                                      (subseq opt-forms (- maxargs minargs)))
940                                              (when allow-other-keys '(&allow-other-keys))
941                                              )))
942                               ,form1))
943                      ,form2)
944              `(,op ((,fname (,@arg-names
945                              ,@(when keyarg-p
946                                  (append '(&key)
947                                          (mapcar #'list
948                                                  key-arg-names
949                                                  opt-forms )
950                                          (when allow-other-keys '(&allow-other-keys))
951                                          )))
952                             ,form1))
953                    ,form2))))))))
954
955(defun make-random-tagbody (size)
956  (let* ((num-forms (random 6))
957         (tags nil))
958    (loop for i below num-forms
959          do (loop for tag = (rcase
960                              #-allegro (1 (random 8))
961                              (1 (random-from-seq #(tag1 tag2 tag3 tag4
962                                                         tag5 tag6 tag7 tag8))))
963                   while (member tag tags)
964                   finally (push tag tags)))
965    (assert (= (length (remove-duplicates tags)) (length tags)))
966    (let* ((*go-tags* (set-difference *go-tags* tags))
967           (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil))
968           (forms
969            (loop for tag-list on tags
970                  for i below num-forms
971                  for size in sizes
972                  collect (let ((*go-tags* (append tag-list *go-tags*)))
973                            (make-random-integer-form size)))))
974      `(tagbody ,@(loop for tag in tags
975                        for form in forms
976                        when (atom form) do (setq form `(progn ,form))
977                        append `(,form ,tag))))))
978
979(defun make-random-tagbody-and-progn (size)
980  (let* ((final-size (random (max 1 (floor size 5))))
981         (tagbody-size (- size final-size)))
982    (let ((final-form (make-random-integer-form final-size))
983          (tagbody-form (make-random-tagbody tagbody-size)))
984      `(progn ,tagbody-form ,final-form))))
985
986(defun make-random-pred-form (size)
987  "Make a random form whose value is to be used as a generalized boolean."
988  (if (<= size 1)
989      (rcase
990        (1 (if (coin) t nil))
991        (2
992         `(,(random-from-seq '(< <= = > >= /= eql equal))
993           ,(make-random-integer-form size)
994           ,(make-random-integer-form size))))
995    (rcase
996      (1 (if (coin) t nil))
997      (3 `(not ,(make-random-pred-form (1- size))))
998      (12 (destructuring-bind (leftsize rightsize)
999             (random-partition (1- size) 2)
1000           `(,(random-from-seq '(and or))
1001             ,(make-random-pred-form leftsize)
1002             ,(make-random-pred-form rightsize))))
1003      (1 (let* ((nsizes (+ 1 (random 3)))
1004                (sizes (random-partition (1- size) nsizes)))
1005           `(,(random-from-seq (if (= nsizes 2) #(< <= > >= = /= eql equal)
1006                                 #(< <= > >= = /=)))
1007             ,@(mapcar #'make-random-integer-form sizes))))
1008      (3 (let* ((cond-size (random (max 1 (floor size 2))))
1009                (then-size (random (- size cond-size)))
1010                (else-size (- size 1 cond-size then-size))
1011                (pred (make-random-pred-form cond-size))
1012                (then-part (make-random-pred-form then-size))
1013                (else-part (make-random-pred-form else-size)))
1014           `(if ,pred ,then-part ,else-part)))
1015      #-poplog
1016      (1 (destructuring-bind (s1 s2)
1017             (random-partition (1- size) 2)
1018           `(ldb-test ,(make-random-byte-spec-form s1)
1019                      ,(make-random-integer-form s2))))
1020      (2 (let ((form (make-random-integer-form (1- size)))
1021               (op (random-from-seq #(evenp oddp minusp plusp zerop))))
1022           `(,op ,form)))
1023      (2 (destructuring-bind (s1 s2)
1024             (random-partition (1- size) 2)
1025           (let ((arg1 (make-random-integer-form s1))
1026                 (arg2-args (loop repeat s2 collect (make-random-integer))))
1027             (let ((op (random-from-seq #(find position)))
1028                   (test (random-from-seq #(eql = /= < > <= >=)))
1029                   (arg2 (rcase
1030                          (1 (make-array (list s2) :initial-contents arg2-args))
1031                          (1
1032                           (let* ((mask (1- (ash 1 (1+ (random 32))))))
1033                             (make-array (list s2)
1034                                         :initial-contents
1035                                         (mapcar #'(lambda (x) (logand x mask)) arg2-args)
1036                                        :element-type `(integer 0 ,mask))))
1037                          (1 `(quote ,arg2-args)))))
1038               `(,op ,arg1 ,arg2 ,@(rcase
1039                                    (2 nil)
1040                                    (1 (list :test `(quote ,test)))
1041                                    (1 (list :test-not `(quote ,test)))))))))
1042     
1043      (1 (let ((index (random (1+ (random *maximum-random-int-bits*))))
1044               (form (make-random-integer-form (1- size))))
1045           `(logbitp ,index ,form)))
1046      (1 ;; typep form
1047       (let ((subform (make-random-integer-form (- size 2)))
1048             (type
1049              (rcase
1050               (1 `(real ,@(make-random-integer-range)))
1051               (1 `(rational ,@(make-random-integer-range)))
1052               (1 `(rational ,(+ 1/2 (make-random-integer))))
1053               (1 `(rational * ,(+ 1/2 (make-random-integer))))
1054               (1 `(integer ,@(make-random-integer-range)))
1055               (1 `(integer ,(make-random-integer)))
1056               (1 `(integer * ,(make-random-integer)))
1057               (1 'fixnum)
1058               (1 'bignum)
1059               (1 `(integer)))))
1060         `(typep ,subform ',type)))
1061      )))
1062
1063(defun make-random-loop-form (size)
1064  (if (<= size 2)
1065      (make-random-integer-form size)
1066    (let* ((var (random-from-seq #(lv1 lv2 lv3 lv4)))
1067           (count (random 4))
1068           (*vars* (cons (make-var-desc :name var :type nil)
1069                         *vars*)))
1070      (rcase
1071       (1 `(loop for ,var below ,count count ,(make-random-pred-form (- size 2))))
1072       (1 `(loop for ,var below ,count sum ,(make-random-integer-form (- size 2))))
1073       ))))
1074
1075(defun make-random-byte-spec-form (size)
1076  (declare (ignore size))
1077  (let* ((pform (random 33))
1078         (sform (1+ (random 33))))
1079    `(byte ,sform ,pform)))
1080
1081(defgeneric make-random-element-of-type (type)
1082  (:documentation "Create a random element of a lisp type."))
1083
1084(defgeneric make-random-element-of-compound-type (type-op type-args)
1085  (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)")
1086  (:method ((type-op (eql 'or)) type-args)
1087           (assert type-args)
1088           (make-random-element-of-type (random-from-seq type-args)))
1089  (:method ((type-op (eql 'and)) type-args)
1090           (assert type-args)
1091           (loop for x = (make-random-element-of-type (car type-args))
1092             repeat 100
1093             when (typep x (cons 'and (cdr type-args)))
1094             return x
1095             finally (error "Cannot generate random element of ~A"
1096                            (cons type-op type-args))))
1097  (:method ((type-op (eql 'not)) type-args)
1098           (assert (eql (length type-args) 1))
1099           (make-random-element-of-type `(and t (not ,(car type-args)))))
1100  (:method ((type-op (eql 'integer)) type-args)
1101           (let ((lo (let ((lo (car type-args)))
1102                       (cond
1103                        ((consp lo) (1+ (car lo)))
1104                        ((eq lo nil) '*)
1105                        (t lo))))
1106                 (hi (let ((hi (cadr type-args)))
1107                       (cond
1108                        ((consp hi) (1- (car hi)))
1109                        ((eq hi nil) '*)
1110                        (t hi)))))
1111             (if (eq lo '*)
1112                 (if (eq hi '*)
1113                     (let ((x (ash 1 (random *maximum-random-int-bits*))))
1114                       (random-from-interval x (- x)))
1115                   (random-from-interval (1+ hi)
1116                                         (- hi (random (ash 1 *maximum-random-int-bits*)))))
1117           
1118               (if (eq hi '*)
1119                   (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
1120                                         lo)
1121                 ;; May generalize the next case to increase odds
1122                 ;; of certain integers (near 0, near endpoints, near
1123                 ;; powers of 2...)
1124                 (random-from-interval (1+ hi) lo)))))
1125  (:method ((type-op (eql 'rational)) type-args)
1126           (let ((type (cons type-op type-args)))
1127             (or
1128              (let ((r (make-random-element-of-type 'rational)))
1129                (and (typep r type) r))
1130              (let ((lo (car type-args))
1131                    (hi (cadr type-args))
1132                    lo= hi=)
1133                (cond
1134                 ((consp lo) nil)
1135                 ((member lo '(* nil))
1136                  (setq lo nil)
1137                  (setq lo= nil))
1138                 (t
1139                  (assert (typep lo 'rational))
1140                  (setq lo= t)))
1141                (cond
1142                 ((consp hi) nil)
1143                 ((member hi '(* nil))
1144                  (setq hi nil)
1145                  (setq hi= nil))
1146                 (t
1147                  (assert (typep hi 'rational))
1148                  (setq hi= t)))
1149                (assert (or (null lo) (null hi) (<= lo hi)))
1150                (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
1151                (cond
1152                 ((null lo)
1153                  (cond
1154                   ((null hi) (make-random-rational))
1155                   (hi= (- hi (make-random-nonnegative-rational)))
1156                   (t (- hi (make-random-positive-rational)))))
1157                 ((null hi)
1158                  (cond
1159                   (lo= (+ lo (make-random-nonnegative-rational)))
1160                   (t (+ lo (make-random-positive-rational)))))
1161                 (t
1162                  (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))))
1163 
1164  (:method ((type-op (eql 'ratio)) type-args)
1165           (let ((r 0))
1166             (loop
1167              do (setq r (make-random-element-of-compound-type 'rational type-args))
1168              while (integerp r))
1169             r))
1170 
1171  (:method ((type-op (eql 'real)) type-args)
1172           (rcase
1173            (1 (let ((lo (and (numberp (car type-args))
1174                              (rational (car type-args))))
1175                     (hi (and (numberp (cadr type-args))
1176                              (rational (cadr type-args)))))
1177                 (make-random-element-of-compound-type 'rational
1178                                                       `(,(or lo '*)
1179                                                         ,(or hi '*)))))
1180            (1 (make-random-element-of-compound-type 'float
1181                                                     `(,(or (car type-args) '*)
1182                                                       ,(or (cadr type-args) '*))))))
1183 
1184  (:method ((type-op (eql 'float)) type-args)
1185           (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float)))
1186                  (lo (car type-args))
1187                  (hi (cadr type-args))
1188                  (most-neg (most-negative-float new-type-op))
1189                  (most-pos (most-positive-float new-type-op)))
1190             (cond
1191              ((or (and (realp lo) (< lo most-neg))
1192                   (and (realp hi) (> hi most-pos)))
1193               ;; try again
1194               (make-random-element-of-compound-type type-op type-args))
1195              (t
1196               (when (and (realp lo) (not (typep lo new-type-op)))
1197                 (cond
1198                  ((< lo most-neg) (setq lo '*))
1199                  (t (setq lo (coerce lo new-type-op)))))
1200               (when (and (realp hi) (not (typep hi new-type-op)))
1201                 (cond
1202                  ((> hi most-pos) (setq hi '*))
1203                  (t (setq hi (coerce hi new-type-op)))))
1204               (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*)))))))
1205 
1206  (:method ((type-op (eql 'short-float)) type-args)
1207           (assert (<= (length type-args) 2))
1208           (apply #'make-random-element-of-float-type type-op type-args))
1209  (:method ((type-op (eql 'single-float)) type-args)
1210           (assert (<= (length type-args) 2))
1211           (apply #'make-random-element-of-float-type type-op type-args))
1212  (:method ((type-op (eql 'double-float)) type-args)
1213           (assert (<= (length type-args) 2))
1214           (apply #'make-random-element-of-float-type type-op type-args))
1215  (:method ((type-op (eql 'long-float)) type-args)
1216           (assert (<= (length type-args) 2))
1217           (apply #'make-random-element-of-float-type type-op type-args))
1218 
1219  (:method ((type-op (eql 'mod)) type-args)
1220           (let ((modulus (second type-args)))
1221             (assert (integerp modulus))
1222             (assert (plusp modulus))
1223             (make-random-element-of-compound-type 'integer `(0 (,modulus)))))
1224 
1225  (:method ((type-op (eql 'unsigned-byte)) type-args)
1226           (assert (<= (length type-args) 1))
1227           (if (null type-args)
1228               (make-random-element-of-type '(integer 0 *))
1229             (let ((bits (first type-args)))
1230               (if (eq bits '*)
1231                   (make-random-element-of-type '(integer 0 *))
1232                 (progn
1233                   (assert (and (integerp bits) (>= bits 1)))
1234                   (make-random-element-of-type
1235                    `(integer 0 ,(1- (ash 1 bits)))))))))
1236 
1237  (:method ((type-op (eql 'signed-byte)) type-args)
1238           (assert (<= (length type-args) 1))
1239           (if (null type-args)
1240               (make-random-element-of-type 'integer)
1241             (let ((bits (car type-args)))
1242               (if (eq bits'*)
1243                   (make-random-element-of-type 'integer)
1244                 (progn
1245                   (assert (and (integerp bits) (>= bits 1)))
1246                   (make-random-element-of-type
1247                    `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits))))))))))
1248
1249  (:method ((type-op (eql 'eql)) type-args)
1250           (assert (= (length type-args) 1))
1251           (car type-args))
1252
1253  (:method ((type-op (eql 'member)) type-args)
1254           (assert type-args)
1255           (random-from-seq type-args))
1256 
1257  (:method ((type-op (eql 'vector)) type-args)
1258           (assert (<= (length type-args) 2))
1259           (let ((etype-spec (if type-args (car type-args) '*))
1260                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
1261             (make-random-vector etype-spec size-spec)))
1262 
1263  (:method ((type-op (eql 'aimple-vector)) type-args)
1264           (assert (<= (length type-args) 1))
1265           (let ((size-spec (if type-args (car type-args) '*)))
1266             (make-random-vector t size-spec :simple t)))
1267 
1268  (:method ((type-op (eql 'array)) type-args)
1269           (assert (<= (length type-args) 2))
1270           (let ((etype-spec (if type-args (car type-args) '*))
1271                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
1272             (make-random-array etype-spec size-spec)))
1273 
1274  (:method ((type-op (eql 'simple-array)) type-args)
1275           (assert (<= (length type-args) 2))
1276           (let ((etype-spec (if type-args (car type-args) '*))
1277                 (size-spec (if (cdr type-args) (cadr type-args) '*)))
1278             (make-random-array etype-spec size-spec :simple t)))
1279
1280  (:method ((type-op (eql 'string)) type-args)
1281           (assert (<= (length type-args) 1))
1282           (let ((size-spec (if type-args (car type-args) '*)))
1283             (make-random-string size-spec)))
1284
1285  (:method ((type-op (eql 'simple-string)) type-args)
1286           (assert (<= (length type-args) 1))
1287           (let ((size-spec (if type-args (car type-args) '*)))
1288             (make-random-string size-spec :simple t)))
1289 
1290  (:method ((type-op (eql 'base-string)) type-args)
1291           (assert (<= (length type-args) 1))
1292           (let ((size-spec (if type-args (car type-args) '*)))
1293             (make-random-vector 'base-char size-spec)))
1294 
1295  (:method ((type-op (eql 'simple-base-string)) type-args)
1296           (assert (<= (length type-args) 1))
1297           (let ((size-spec (if type-args (car type-args) '*)))
1298             (make-random-vector 'base-char size-spec :simple t)))
1299 
1300  (:method ((type-op (eql 'bit-vector)) type-args)
1301           (assert (<= (length type-args) 1))
1302           (let ((size-spec (if type-args (car type-args) '*)))
1303             (make-random-vector 'bit size-spec)))
1304 
1305  (:method ((type-op (eql 'simple-bit-vector)) type-args)
1306           (assert (<= (length type-args) 1))
1307           (let ((size-spec (if type-args (car type-args) '*)))
1308             (make-random-vector 'bit size-spec :simple t)))
1309 
1310  (:method ((type-op (eql 'cons)) type-args)
1311           (assert (<= (length type-args) 2))
1312           (cons (make-random-element-of-type (if type-args (car type-args) t))
1313                 (make-random-element-of-type (if (cdr type-args) (cadr type-args) t))))
1314 
1315  (:method ((type-op (eql 'complex)) type-args)
1316           (cond
1317            ((null type-args)
1318             (make-random-element-of-type 'complex))
1319            (t
1320             (assert (null (cdr type-args)))
1321             (let ((etype (car type-args)))
1322               (loop for v1 = (make-random-element-of-type etype)
1323                     for v2 = (make-random-element-of-type etype)
1324                     for c = (complex v1 v2)
1325                     when (typep c (cons 'complex type-args))
1326                     return c)))))
1327  )
1328
1329(defmethod make-random-element-of-type ((type cons))
1330  (make-random-element-of-compound-type (car type) (cdr type)))
1331
1332(defun make-random-element-of-float-type (type-op &optional lo hi)
1333  (let (lo= hi=)
1334    (cond
1335     ((consp lo) nil)
1336     ((member lo '(* nil))
1337      (setq lo (most-negative-float type-op))
1338      (setq lo= t))
1339     (t
1340      (assert (typep lo type-op))
1341      (setq lo= t)))
1342    (cond
1343     ((consp hi) nil)
1344     ((member hi '(* nil))
1345      (setq hi (most-positive-float type-op))
1346      (setq hi= t))
1347     (t
1348      (assert (typep hi type-op))
1349      (setq hi= t)))
1350    (assert (<= lo hi))
1351    (assert (or (< lo hi) (and lo= hi=)))
1352    (let ((limit 100000))
1353      (cond
1354       ((or (<= hi 0)
1355            (>= lo 0)
1356            (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
1357        (loop for x = (+ (random (- hi lo)) lo)
1358              do (when (or lo= (/= x lo)) (return x))))
1359       (t
1360        (rcase
1361         (1 (random (min hi (float limit hi))))
1362         (1 (- (random (min (float limit lo) (- lo)))))))))))
1363 
1364#|
1365(defmethod make-random-element-of-type ((type cons))
1366  (let ((type-op (first type)))
1367    (ecase type-op
1368      (or
1369       (assert (cdr type))
1370       (make-random-element-of-type (random-from-seq (cdr type))))
1371      (and
1372       (assert (cdr type))
1373       (loop for x = (make-random-element-of-type (cadr type))
1374             repeat 100
1375             when (typep x (cons 'and (cddr type)))
1376             return x
1377             finally (error "Cannot generate random element of ~A" type)))
1378      (not
1379       (assert (cdr type))
1380       (assert (not (cddr type)))
1381       (make-random-element-of-type `(and t ,type)))
1382      (integer
1383       (let ((lo (let ((lo (cadr type)))
1384                   (cond
1385                    ((consp lo) (1+ (car lo)))
1386                    ((eq lo nil) '*)
1387                    (t lo))))
1388             (hi (let ((hi (caddr type)))
1389                   (cond
1390                    ((consp hi) (1- (car hi)))
1391                    ((eq hi nil) '*)
1392                    (t hi)))))
1393         (if (eq lo '*)
1394             (if (eq hi '*)
1395                 (let ((x (ash 1 (random *maximum-random-int-bits*))))
1396                   (random-from-interval x (- x)))
1397               (random-from-interval (1+ hi)
1398                                     (- hi (random (ash 1 *maximum-random-int-bits*)))))
1399           
1400           (if (eq hi '*)
1401               (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1)
1402                                     lo)
1403             ;; May generalize the next case to increase odds
1404             ;; of certain integers (near 0, near endpoints, near
1405             ;; powers of 2...)
1406             (random-from-interval (1+ hi) lo)))))
1407     
1408      (rational
1409       (or
1410        (let ((r (make-random-element-of-type 'rational)))
1411          (and (typep r type) r))
1412        (let ((lo (cadr type))
1413              (hi (caddr type))
1414              lo= hi=)
1415          (cond
1416           ((consp lo) nil)
1417           ((member lo '(* nil))
1418            (setq lo nil)
1419            (setq lo= nil))
1420           (t
1421            (assert (typep lo 'rational))
1422            (setq lo= t)))
1423          (cond
1424           ((consp hi) nil)
1425           ((member hi '(* nil))
1426            (setq hi nil)
1427            (setq hi= nil))
1428           (t
1429            (assert (typep hi 'rational))
1430            (setq hi= t)))
1431          (assert (or (null lo) (null hi) (<= lo hi)))
1432          (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=)))
1433          (cond
1434           ((null lo)
1435            (cond
1436             ((null hi) (make-random-rational))
1437             (hi= (- hi (make-random-nonnegative-rational)))
1438             (t (- hi (make-random-positive-rational)))))
1439           ((null hi)
1440            (cond
1441             (lo= (+ lo (make-random-nonnegative-rational)))
1442             (t (+ lo (make-random-positive-rational)))))
1443           (t
1444            (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))
1445     
1446      (ratio
1447       (let ((r 0))
1448         (loop
1449          do (setq r (make-random-element-of-type `(rational ,@(cdr type))))
1450          while (integerp r))
1451         r))
1452     
1453      (real
1454       (rcase
1455        (1 (let ((lo (and (numberp (cadr type))
1456                          (rational (cadr type))))
1457                 (hi (and (numberp (caddr type))
1458                          (rational (caddr type)))))
1459             (make-random-element-of-type `(rational ,(or lo '*)
1460                                                     ,(or hi '*)))))
1461        (1 (make-random-element-of-type `(float ,(or (cadr type) '*)
1462                                                ,(or (caddr type) '*))))))
1463     
1464      ((float)
1465       (let* ((new-type-op (random-from-seq #(single-float double-float
1466                                                           long-float short-float)))
1467              (lo (cadr type))
1468              (hi (caddr type))
1469              (most-neg (most-negative-float new-type-op))
1470              (most-pos (most-positive-float new-type-op)))
1471         (cond
1472          ((or (and (realp lo) (< lo most-neg))
1473               (and (realp hi) (> hi most-pos)))
1474           ;; try again
1475           (make-random-element-of-type type))
1476          (t
1477           (when (and (realp lo) (not (typep lo new-type-op)))
1478             (cond
1479              ((< lo most-neg) (setq lo '*))
1480              (t (setq lo (coerce lo new-type-op)))))
1481           (when (and (realp hi) (not (typep hi new-type-op)))
1482             (cond
1483              ((> hi most-pos) (setq hi '*))
1484              (t (setq hi (coerce hi new-type-op)))))
1485           (make-random-element-of-type
1486            `(,new-type-op ,(or lo '*) ,(or hi '*)))))))
1487     
1488      ((single-float double-float long-float short-float)
1489       (let ((lo (cadr type))
1490             (hi (caddr type))
1491             lo= hi=)
1492         (cond
1493          ((consp lo) nil)
1494          ((member lo '(* nil))
1495           (setq lo (most-negative-float type-op))
1496           (setq lo= t))
1497          (t
1498           (assert (typep lo type-op))
1499           (setq lo= t)))
1500         (cond
1501          ((consp hi) nil)
1502          ((member hi '(* nil))
1503           (setq hi (most-positive-float type-op))
1504           (setq hi= t))
1505          (t
1506           (assert (typep hi type-op))
1507           (setq hi= t)))
1508         (assert (<= lo hi))
1509         (assert (or (< lo hi) (and lo= hi=)))
1510         (let ((limit 100000))
1511           (cond
1512            ((or (<= hi 0)
1513                 (>= lo 0)
1514                 (and (<= (- limit) hi limit) (<= (- limit) lo limit)))
1515             (loop for x = (+ (random (- hi lo)) lo)
1516                   do (when (or lo= (/= x lo)) (return x))))
1517            (t
1518             (rcase
1519              (1 (random (min hi (float limit hi))))
1520              (1 (- (random (min (float limit lo) (- lo)))))))))))
1521     
1522      (mod
1523       (let ((modulus (second type)))
1524         (assert (and (integerp modulus)
1525                      (plusp modulus)))
1526         (make-random-element-of-type `(integer 0 (,modulus)))))
1527      (unsigned-byte
1528       (if (null (cdr type))
1529           (make-random-element-of-type '(integer 0 *))
1530         (let ((bits (second type)))
1531           (if (eq bits'*)
1532               (make-random-element-of-type '(integer 0 *))
1533             (progn
1534               (assert (and (integerp bits) (>= bits 1)))
1535               (make-random-element-of-type
1536                `(integer 0 ,(1- (ash 1 bits)))))))))
1537      (signed-byte
1538       (if (null (cdr type))
1539           (make-random-element-of-type 'integer)
1540         (let ((bits (second type)))
1541           (if (eq bits'*)
1542               (make-random-element-of-type 'integer)
1543             (progn
1544               (assert (and (integerp bits) (>= bits 1)))
1545               (make-random-element-of-type
1546                `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits))))))))))
1547      (eql
1548       (assert (= (length type) 2))
1549       (cadr type))
1550      (member
1551       (assert (cdr type))
1552       (random-from-seq (cdr type)))
1553      ((vector)
1554       (let ((etype-spec (if (cdr type) (cadr type) '*))
1555             (size-spec (if (cddr type) (caddr type) '*)))
1556         (make-random-vector etype-spec size-spec)))
1557      ((simple-vector)
1558       (let ((size-spec (if (cdr type) (cadr type) '*)))
1559         (make-random-vector t size-spec :simple t)))
1560      ((array simple-array)
1561       (let ((etype-spec (if (cdr type) (cadr type) '*))
1562             (size-spec (if (cddr type) (caddr type) '*)))
1563         (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array))))
1564      ((string simple-string)
1565       (let ((size-spec (if (cdr type) (cadr type) '*)))
1566         (make-random-string size-spec :simple (eql (car type) 'simple-string))))
1567      ((base-string simple-base-string)
1568       (let ((size-spec (if (cdr type) (cadr type) '*)))
1569         (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string))))
1570      ((bit-vector simple-bit-vector)
1571       (let ((size-spec (if (cdr type) (cadr type) '*)))
1572         (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector))))
1573      ((cons)
1574       (cons (make-random-element-of-type (if (cdr type) (cadr type) t))
1575             (make-random-element-of-type (if (cddr type) (caddr type) t))))
1576      ((complex)
1577       (cond
1578        ((null (cdr type))
1579         (make-random-element-of-type 'complex))
1580        (t
1581         (assert (null (cddr type)))
1582         (let ((etype (cadr type)))
1583           (loop for v1 = (make-random-element-of-type etype)
1584                 for v2 = (make-random-element-of-type etype)
1585                 for c = (complex v1 v2)
1586                 when (typep c type)
1587                 return c)))))
1588      )))
1589|#
1590
1591(defmethod make-random-element-of-type ((type class))
1592  (make-random-element-of-type (class-name type)))
1593
1594(defmethod make-random-element-of-type ((type (eql 'bit))) (random 2))
1595(defmethod make-random-element-of-type ((type (eql 'boolean)))
1596  (random-from-seq #(nil t)))
1597(defmethod make-random-element-of-type ((type (eql 'symbol)))
1598  (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
1599(defmethod make-random-element-of-type ((type (eql 'keyword)))
1600  (random-from-seq #(:a :b :c :d :e :f :g :h :i :j)))
1601(defmethod make-random-element-of-type ((type (eql 'unsigned-byte)))
1602  (random-from-interval (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
1603(defmethod make-random-element-of-type ((type (eql 'signed-byte)))
1604  (random-from-interval
1605   (1+ (ash 1 (random *maximum-random-int-bits*)))
1606   (- (ash 1 (random *maximum-random-int-bits*)))))
1607(defmethod make-random-element-of-type ((type (eql 'rational)))
1608  (make-random-rational))
1609(defmethod make-random-element-of-type ((type (eql 'ratio)))
1610  (let ((r 0))
1611    (loop do (setq r (make-random-element-of-type 'rational))
1612          while (integerp r))
1613    r))
1614(defmethod make-random-element-of-type ((type (eql 'integer)))
1615  (let ((x (ash 1 (random *maximum-random-int-bits*))))
1616    (random-from-interval (1+ x) (- x))))
1617(defmethod make-random-element-of-type ((type (eql 'float)))
1618  (make-random-element-of-type
1619   (random-from-seq #(short-float single-float double-float long-float))))
1620(defmethod make-random-element-of-type ((type (eql 'real)))
1621  (make-random-element-of-type (random-from-seq #(integer rational float))))
1622(defmethod make-random-element-of-type ((type (eql 'number)))
1623  (make-random-element-of-type (random-from-seq #(integer rational float #-ecl complex))))
1624(defmethod make-random-element-of-type ((type (eql 'bit-vector)))
1625  (make-random-vector 'bit '*))
1626(defmethod make-random-element-of-type ((type (eql 'simple-bit-vector)))
1627  (make-random-vector 'bit '* :simple t))
1628(defmethod make-random-element-of-type ((type (eql 'vector)))
1629  (make-random-vector '* '*))
1630(defmethod make-random-element-of-type ((type (eql 'simple-vector)))
1631  (make-random-vector 't '* :simple t))
1632(defmethod make-random-element-of-type ((type (eql 'array)))
1633  (make-random-array '* '*))
1634(defmethod make-random-element-of-type ((type (eql 'simple-array)))
1635  (make-random-array '* '* :simple t))
1636(defmethod make-random-element-of-type ((type (eql 'string)))
1637  (make-random-string '*))
1638(defmethod make-random-element-of-type ((type (eql 'simple-string)))
1639  (make-random-string '* :simple t))
1640(defmethod make-random-element-of-type ((type (eql 'base-string)))
1641  (make-random-vector 'base-char '*))
1642(defmethod make-random-element-of-type ((type (eql 'simple-base-string)))
1643  (make-random-vector 'base-char '* :simple t))
1644(defmethod make-random-element-of-type ((type (eql 'character)))
1645  (make-random-character))
1646(defmethod make-random-element-of-type ((type (eql 'extended-char)))
1647  (loop for x = (make-random-character)
1648        when (typep x 'extended-char) return x))
1649(defmethod make-random-element-of-type ((type (eql 'null))) nil)
1650(defmethod make-random-element-of-type ((type (eql 'fixnum)))
1651  (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum))
1652(defmethod make-random-element-of-type ((type (eql 'complex)))
1653  (make-random-element-of-type '(complex real)))
1654(defmethod make-random-element-of-type ((type (eql 'cons)))
1655  (make-random-element-of-type '(cons t t)))
1656(defmethod make-random-element-of-type ((type (eql 'list)))
1657  ;; Should modify this to allow non-proper lists?
1658  (let ((len (min (random 10) (random 10))))
1659    (loop repeat len collect (make-random-element-of-type t))))
1660(defmethod make-random-element-of-type ((type (eql 'sequence)))
1661  (make-random-element-of-type '(or list vector)))
1662(defmethod make-random-element-of-type ((type (eql 'function)))
1663  (rcase
1664   (5 (symbol-function (random-from-seq *cl-function-symbols*)))
1665   (5 (symbol-function (random-from-seq *cl-accessor-symbols*)))
1666   (1 #'(lambda (x) (cons x x)))
1667   (1 (eval '#'(lambda (x) (cons x x))))))
1668
1669(defmethod make-random-element-of-type ((type symbol))
1670  (case type
1671   ((single-float short-float double-float long-float)
1672    (make-random-element-of-type (list type)))
1673   ((base-char standard-char)
1674    (random-from-seq +standard-chars+))
1675   ;; Default
1676   ((atom t *) (make-random-element-of-type
1677                (random-from-seq #(real symbol boolean integer unsigned-byte
1678                                        #-ecl complex character
1679                                        (string 1) (bit-vector 1)))))
1680   (t (call-next-method type))
1681   ))
1682
1683(defun make-random-character ()
1684  (loop
1685   when (rcase
1686         (3 (random-from-seq +standard-chars+))
1687         (3 (code-char (random (min 256 char-code-limit))))
1688         (1 (code-char (random (min (ash 1 16) char-code-limit))))
1689         (1 (code-char (random (min (ash 1 24) char-code-limit))))
1690         (1 (code-char (random char-code-limit))))
1691   return it))
1692
1693(defun make-random-array-element-type ()
1694  ;; Create random types for array elements
1695  (let ((bits 40))
1696    (rcase
1697     (2 t)
1698     (1 'symbol)
1699     (1 `(unsigned-byte ,(1+ (random bits))))
1700     (1 `(signed-byte ,(1+ (random bits))))
1701     (1 'character)
1702     (1 'base-char)
1703     (1 'bit)
1704     (1 (random-from-seq #(short-float single-float double-float long-float))))))
1705
1706(defun make-random-vector (etype-spec size-spec &key simple)
1707  (let* ((etype (if (eql etype-spec '*)
1708                    (make-random-array-element-type)
1709                  etype-spec))
1710         (size (if (eql size-spec '*)
1711                   (random (ash 1 (+ 2 (random 8))))
1712                 size-spec))
1713         (displaced? (and (not simple) (coin 4)))
1714         (displaced-size (+ size (random (max 6 size))))
1715         (displacement (random (1+ (- displaced-size size))))
1716         (adjustable (and (not simple) (coin 3)))
1717         (fill-pointer (and (not simple)
1718                            (rcase (3 nil) (1 t) (1 (random (1+ size)))))))
1719    (assert (<= size 1000000))
1720    (if displaced?
1721        (let ((displaced-vector (make-array displaced-size :element-type etype
1722                                            :initial-contents (loop repeat displaced-size
1723                                                                    collect (make-random-element-of-type etype)))))
1724          (make-array size :element-type etype :adjustable adjustable
1725                      :fill-pointer fill-pointer
1726                      :displaced-to displaced-vector
1727                      :displaced-index-offset displacement))
1728      (make-array size
1729                  :element-type etype
1730                  :initial-contents (loop repeat size
1731                                          collect (make-random-element-of-type etype))
1732                  :adjustable adjustable
1733                  :fill-pointer fill-pointer
1734                  ))))
1735
1736(defun make-random-array (etype-spec dim-specs &key simple)
1737  (when (eql dim-specs '*)
1738    (setq dim-specs (random 10)))
1739  (when (numberp dim-specs)
1740    (setq dim-specs (make-list dim-specs :initial-element '*)))
1741  (let* ((etype (if (eql etype-spec '*) t etype-spec))
1742         (rank (length dim-specs))
1743         (dims (loop for dim in dim-specs
1744                     collect (if (eql dim '*)
1745                                 (1+ (random (ash 1 (floor 9 rank))))
1746                               dim))))
1747    (assert (<= (reduce '* dims :initial-value 1) 1000000))
1748    (assert (<= (reduce 'max dims :initial-value 1) 1000000))
1749    (make-array dims
1750                :element-type etype
1751                :initial-contents
1752                (labels ((%init (dims)
1753                                (if (null dims)
1754                                    (make-random-element-of-type etype)
1755                                  (loop repeat (car dims)
1756                                        collect (%init (cdr dims))))))
1757                  (%init dims))
1758                :adjustable (and (not simple) (coin))
1759                ;; Do displacements later
1760                )))
1761
1762(defun most-negative-float (float-type-symbol)
1763  (ecase float-type-symbol
1764    (short-float most-negative-short-float)
1765    (single-float most-negative-single-float)
1766    (double-float most-negative-double-float)
1767    (long-float most-negative-long-float)
1768    (float (min most-negative-short-float most-negative-single-float
1769                most-negative-double-float most-negative-long-float))))
1770
1771(defun most-positive-float (float-type-symbol)
1772  (ecase float-type-symbol
1773    (short-float most-positive-short-float)
1774    (single-float most-positive-single-float)
1775    (double-float most-positive-double-float)
1776    (long-float most-positive-long-float)
1777    (float (max most-positive-short-float most-positive-single-float
1778                most-positive-double-float most-positive-long-float))))
1779
1780(defun make-optimized-lambda-form (form vars var-types opt-decls)
1781  `(lambda ,vars
1782     ,@(mapcar #'(lambda (tp var) `(declare (type ,tp ,var)))
1783               var-types vars)
1784     (declare (ignorable ,@vars))
1785     #+cmu (declare (optimize (extensions:inhibit-warnings 3)))
1786     (declare (optimize ,@opt-decls))
1787     ,form))
1788
1789(defun make-unoptimized-lambda-form (form vars var-types opt-decls)
1790  (declare (ignore var-types))
1791  `(lambda ,vars
1792     (declare (notinline ,@(fn-symbols-in-form form)))
1793     #+cmu (declare (optimize (extensions:inhibit-warnings 3)))
1794     (declare (optimize ,@opt-decls))
1795     ,form))
1796
1797(defvar *compile-using-defun*
1798  #-(or allegro lispworks) nil
1799  #+(or allegro lispworks) t)
1800
1801(defvar *compile-using-defgeneric* nil
1802  "If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form
1803   for the function and compile that.")
1804
1805(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
1806(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
1807
1808(defun test-int-form (form vars var-types vals-list opt-decls-1 opt-decls-2)
1809  ;; Try to compile FORM with associated VARS, and if it compiles
1810  ;; check for equality of the two compiled forms.
1811  ;; Return a non-nil list of details if a problem is found,
1812  ;; NIL otherwise.
1813  (let ((optimized-fn-src (make-optimized-lambda-form form vars var-types opt-decls-1))
1814        (unoptimized-fn-src (make-unoptimized-lambda-form form vars var-types opt-decls-2)))
1815    (setq *int-form-vals* nil
1816          *optimized-fn-src* optimized-fn-src
1817          *unoptimized-fn-src* unoptimized-fn-src)
1818    (flet ((%compile
1819            (lambda-form opt-defun-name)
1820            (cl:handler-bind
1821             (#+sbcl (sb-ext::compiler-note #'muffle-warning)
1822                     (warning #'muffle-warning)
1823                     ((or error serious-condition)
1824                      #'(lambda (c)
1825                                (format t "Compilation failure~%~A~%"
1826                                        (format nil "~S" form))
1827                                (finish-output *standard-output*)
1828                                (return-from test-int-form
1829                                  (list (list :vars vars
1830                                              :form form
1831                                              :var-types var-types
1832                                              :vals (first vals-list)
1833                                              :lambda-form lambda-form
1834                                              :decls1 opt-decls-1
1835                                              :decls2 opt-decls-2
1836                                              :compiler-condition
1837                                              (with-output-to-string
1838                                                (s)
1839                                                (prin1 c s))))))))
1840             (let ((start-time (get-universal-time))
1841                   (clf (cdr lambda-form)))
1842               (prog1
1843                   (cond
1844                    (*compile-using-defun*
1845                     (fmakunbound opt-defun-name)
1846                     (eval `(defun ,opt-defun-name ,@clf))
1847                     (compile opt-defun-name)
1848                     (symbol-function opt-defun-name))
1849                    (*compile-using-defgeneric*
1850                     (fmakunbound opt-defun-name)
1851                     (eval `(defgeneric ,opt-defun-name ,(car clf)))
1852                     (eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf))
1853                              ,@(cdr clf)))
1854                     (compile opt-defun-name)
1855                     (symbol-function opt-defun-name))
1856                    (t (compile nil lambda-form)))
1857                 (let* ((stop-time (get-universal-time))
1858                        (total-time (- stop-time start-time)))
1859                   (when (> total-time *max-compile-time*)
1860                     (setf *max-compile-time* total-time)
1861                     (setf *max-compile-term* lambda-form)))
1862                 ;; #+:ecl (si:gc t)
1863                 )))))
1864      (let ((optimized-compiled-fn (%compile optimized-fn-src
1865                                             *name-to-use-in-optimized-defun*))
1866            (unoptimized-compiled-fn
1867             (if *compile-unoptimized-form*
1868                 (%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*)
1869               (eval `(function ,unoptimized-fn-src)))))
1870        (declare (type function optimized-compiled-fn unoptimized-compiled-fn))
1871        (dolist (vals vals-list)
1872          (setq *int-form-vals* vals)
1873          (flet ((%eval-error
1874                  (kind)
1875                  (let ((*print-circle* t))
1876                    (format t "~A~%" (format nil "~S" form)))
1877                  (finish-output *standard-output*)
1878                  (return
1879                   (list (list :vars vars
1880                               :vals vals
1881                               :form form
1882                               :var-types var-types
1883                               :decls1 opt-decls-1
1884                               :decls2 opt-decls-2
1885                               :optimized-lambda-form optimized-fn-src
1886                               :unoptimized-lambda-form unoptimized-fn-src
1887                               :kind kind)))))
1888             
1889            (let ((unopt-result
1890                   (cl-handler-case
1891                    (cl-handler-bind
1892                     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
1893                             (warning #'muffle-warning))
1894                     (identity ;; multiple-value-list
1895                      (apply unoptimized-compiled-fn vals)))
1896                    ((or error serious-condition)
1897                     (c)
1898                     (%eval-error (list :unoptimized-form-error
1899                                        (with-output-to-string
1900                                          (s) (prin1 c s)))))))
1901                  (opt-result
1902                   (cl-handler-case
1903                    (cl-handler-bind
1904                     (#+sbcl (sb-ext::compiler-note #'muffle-warning)
1905                             (warning #'muffle-warning))
1906                     (identity ;; multiple-value-list
1907                      (apply optimized-compiled-fn vals)))
1908                    ((or error serious-condition)
1909                     (c)
1910                     (%eval-error (list :optimized-form-error
1911                                        (with-output-to-string
1912                                          (s) (prin1 c s))))))))
1913              (if (equal opt-result unopt-result)
1914                  nil
1915                (progn
1916                  (format t "Different results: ~A, ~A~%"
1917                          opt-result unopt-result)
1918                  (setq *opt-result* opt-result
1919                        *unopt-result* unopt-result)
1920                  (%eval-error (list :different-results
1921                                     opt-result
1922                                     unopt-result)))))))))))
1923
1924;;; Interface to the form pruner
1925
1926(declaim (special *prune-table*))
1927
1928(defun prune-int-form (input-form vars var-types vals-list opt-decls-1 opt-decls-2)
1929  "Conduct tests on selected simplified versions of INPUT-FORM.  Return the
1930   minimal form that still causes some kind of failure."
1931  (loop do
1932        (let ((form input-form))
1933          (flet ((%try-fn (new-form)
1934                          (when (test-int-form new-form vars var-types vals-list
1935                                               opt-decls-1 opt-decls-2)
1936                            (setf form new-form)
1937                            (throw 'success nil))))
1938            (let ((*prune-table* (make-hash-table :test #'eq)))
1939              (loop
1940               (catch 'success
1941                 (prune form #'%try-fn)
1942                 (return form)))))
1943          (when (equal form input-form) (return form))
1944          (setq input-form form))))
1945
1946(defun prune-results (result-list)
1947  "Given a list of test results, prune their forms down to a minimal set."
1948  (loop for result in result-list
1949        collect
1950        (let* ((form (getf result :form))
1951               (vars (getf result :vars))
1952               (var-types (getf result :var-types))
1953               (vals-list (list (getf result :vals)))
1954               (opt-decl-1 (getf result :decls1))
1955               (opt-decl-2 (getf result :decls2))
1956               (pruned-form (prune-int-form form vars var-types vals-list opt-decl-1 opt-decl-2))
1957               (optimized-lambda-form (make-optimized-lambda-form
1958                                       pruned-form vars var-types opt-decl-1))
1959               (unoptimized-lambda-form (make-unoptimized-lambda-form
1960                                         pruned-form vars var-types opt-decl-2)))
1961            `(:vars ,vars
1962              :var-types ,var-types
1963              :vals ,(first vals-list)
1964              :form ,pruned-form
1965              :decls1 ,opt-decl-1
1966              :decls2 ,opt-decl-2
1967              :optimized-lambda-form ,optimized-lambda-form
1968              :unoptimized-lambda-form ,unoptimized-lambda-form))))
1969
1970;;;
1971;;; The call (PRUNE form try-fn) attempts to simplify the lisp form
1972;;; so that it still satisfies TRY-FN.  The function TRY-FN should
1973;;; return if the substitution is a failure.  Otherwise, it should
1974;;; transfer control elsewhere via GO, THROW, etc.
1975;;;
1976;;; The return value of PRUNE should be ignored.
1977;;;
1978(defun prune (form try-fn)
1979  (declare (type function try-fn))
1980  (when (gethash form *prune-table*)
1981    (return-from prune nil))
1982  (flet ((try (x) (funcall try-fn x)))
1983    (cond
1984     ((keywordp form) nil)
1985     ((integerp form)
1986      (unless (zerop form) (try 0)))
1987     ((consp form)
1988      (let* ((op (car form))
1989             (args (cdr form))
1990             (nargs (length args)))
1991        (case op
1992
1993         ((quote) nil)
1994
1995         ((go)
1996          (try 0))
1997         
1998         ((signum integer-length logcount
1999                  logandc1 logandc2 lognand lognor logorc1 logorc2
2000                  realpart imagpart)
2001          (try 0)
2002          (mapc try-fn args)
2003          (prune-fn form try-fn))
2004
2005         ((make-array)
2006          (when (and (eq (car args) nil)
2007                     (eq (cadr args) ':initial-element)
2008                     ; (null (cdddr args))
2009                     )
2010            (prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args)))))
2011            (when (cdddr args)
2012              (try `(make-array nil :initial-element ,(caddr args))))
2013            ))
2014
2015         ((cons)
2016          (prune-fn form try-fn))
2017
2018         ((dotimes)
2019          (try 0)
2020          (let* ((binding-form (first args))
2021                 (body (rest args))
2022                 (var (first binding-form))
2023                 (count-form (second binding-form))
2024                 (result (third binding-form)))
2025            (try result)
2026            (unless (eql count-form 0)
2027              (try `(dotimes (,var 0 ,result) ,@body)))
2028            (prune result #'(lambda (form)
2029                              (try `(dotimes (,var ,count-form ,form) ,@body))))
2030            (when (= (length body) 1)
2031              (prune (first body)
2032                     #'(lambda (form)
2033                         (when (consp form)
2034                           (try `(dotimes (,var ,count-form ,result) ,form))))))))
2035         
2036         ((abs 1+ 1-)
2037          (try 0)
2038          (mapc try-fn args)
2039          (prune-fn form try-fn))
2040
2041         ((identity  ignore-errors cl:handler-case restart-case locally)
2042          (unless (and (consp args)
2043                       (consp (car args))
2044                       (eql (caar args) 'tagbody))
2045            (mapc try-fn args))
2046          (prune-fn form try-fn))
2047
2048         ((boole)
2049          (try (second args))
2050          (try (third args))
2051          (prune (second args)
2052                 #'(lambda (form) (try `(boole ,(first args) ,form ,(third args)))))
2053          (prune (third args)
2054                 #'(lambda (form) (try `(boole ,(first args) ,(second args) ,form)))))
2055
2056         ((unwind-protect prog1 multiple-value-prog1)
2057          (try (first args))
2058          (let ((val (first args))
2059                (rest (rest args)))
2060            (when rest
2061              (try `(unwind-protect ,val))
2062              (when (cdr rest)
2063                (loop for i from 0 below (length rest)
2064                      do
2065                      (try `(unwind-protect ,val
2066                              ,@(subseq rest 0 i)
2067                              ,@(subseq rest (1+ i))))))))
2068          (prune-fn form try-fn))
2069
2070         ((prog2)
2071          (assert (>= (length args) 2))
2072          (let ((val1 (first args))
2073                (arg2 (second args))
2074                (rest (cddr args)))
2075            (try arg2)
2076            (prune-fn form try-fn)
2077            (when rest
2078              (try `(prog2 ,val1 ,arg2))
2079              (when (cdr rest)
2080                (loop for i from 0 below (length rest)
2081                      do
2082                      (try `(prog2 ,val1 ,arg2
2083                              ,@(subseq rest 0 i)
2084                              ,@(subseq rest (1+ i)))))))))
2085
2086         ((typep)
2087          (try (car args))
2088          (prune (car args)
2089                 #'(lambda (form) `(,op ,form ,@(cdr args)))))
2090
2091         ((load-time-value)
2092          (let ((arg (first args)))
2093            (try arg)
2094            (cond
2095             ((cdr args)
2096              (try `(load-time-value ,arg))
2097              (prune arg
2098                     #'(lambda (form)
2099                         (try `(load-time-value ,form ,(second args))))))
2100             (t
2101              (prune arg
2102                     #'(lambda (form)
2103                         (try `(load-time-value ,form))))))))
2104
2105         ((eval)
2106          (try 0)
2107          (let ((arg (first args)))
2108            (cond
2109             ((consp arg)
2110              (cond
2111               ((eql (car arg) 'quote)
2112                (prune (cadr arg) #'(lambda (form) (try `(eval ',form)))))
2113               (t
2114                (try arg)
2115                (prune arg #'(lambda (form) `(eval ,form))))))
2116             (t (try arg)))))
2117
2118         ((the macrolet cl:handler-bind restart-bind)
2119          (assert (= (length args) 2))
2120          (try (second args))
2121          (prune (second args) try-fn))
2122         
2123         ((not eq eql equal)
2124          (when (every #'constantp args)
2125            (try (eval form)))
2126          (try t)
2127          (try nil)
2128          (mapc try-fn args)
2129          (prune-fn form try-fn)
2130          )
2131
2132         ((and or = < > <= >= /=)
2133          (when (every #'constantp args)
2134            (try (eval form)))
2135          (try t)
2136          (try nil)
2137          (mapc try-fn args)
2138          (prune-nary-fn form try-fn)
2139          (prune-fn form try-fn))
2140         
2141         ((- + * min max logand logior logxor logeqv gcd lcm values)
2142          (when (every #'constantp args)
2143            (try (eval form)))
2144          (try 0)
2145          (mapc try-fn args)
2146          (prune-nary-fn form try-fn)
2147          (prune-fn form try-fn))
2148
2149         ((/)
2150          (when (every #'constantp args)
2151            (try (eval form)))
2152          (try 0)
2153          (try (car args))
2154          (when (cddr args)
2155            (prune (car args) #'(lambda (form) (try `(/ ,form ,(second args)))))))
2156
2157         ((expt rationalize rational numberator denominator)
2158          (try 0)
2159          (mapc try-fn args)
2160          (prune-fn form try-fn))
2161         
2162         ((coerce)
2163          (try 0)
2164          (try (car args))
2165          (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args))))))
2166         
2167
2168         ((multiple-value-call)
2169          ;; Simplify usual case
2170          (when (= nargs 2)
2171            (destructuring-bind (arg1 arg2) args
2172              (when (and (consp arg1) (consp arg2)
2173                         (eql (first arg1) 'function)
2174                         (eql (first arg2) 'values))
2175                (mapc try-fn (rest arg2))
2176                (let ((fn (second arg1)))
2177                  (when (symbolp fn)
2178                    (try `(,fn ,@(rest arg2)))))
2179                ;; Prune the VALUES form
2180                (prune-list (rest arg2)
2181                            #'prune
2182                            #'(lambda (args)
2183                                (try `(multiple-value-call ,arg1 (values ,@args)))))
2184                )))
2185          (mapc try-fn (rest args)))
2186
2187         ((bit sbit elt aref svref)
2188          (try 0)
2189          (when (= (length args) 2)
2190            (let ((arg1 (car args))
2191                  (arg2 (cadr args)))
2192              (when (and (consp arg2)
2193                         (eql (car arg2) 'min)
2194                         (integerp (cadr arg2)))
2195                (let ((arg2.2 (caddr arg2)))
2196                  (try arg2.2)
2197                  (when (and (consp arg2.2)
2198                             (eql (car arg2.2) 'max)
2199                             (integerp (cadr arg2.2)))
2200                    (prune (caddr arg2.2)
2201                           #'(lambda (form)
2202                               (try `(,op ,arg1 (min ,(cadr arg2)
2203                                                     (max ,(cadr arg2.2) ,form))))))))))))
2204
2205         ((car cdr)
2206          (try 0)
2207          (try 1))
2208
2209         ((if)
2210          (let (;; (pred (first args))
2211                (then (second args))
2212                (else (third args)))
2213            (try then)
2214            (try else)
2215            (when (every #'constantp args)
2216              (try (eval form)))
2217            (prune-fn form try-fn)))
2218
2219         ((incf decf)
2220          (try 0)
2221          (assert (member (length form) '(2 3)))
2222          (try (first args))
2223          (when (> (length args) 1)
2224            (try (second args))
2225            (try `(,op ,(first args)))
2226            (unless (integerp (second args))
2227              (prune (second args)
2228                     #'(lambda (form)
2229                         (try `(,op ,(first args) ,form)))))))
2230
2231         ((setq setf shiftf)
2232          (try 0)
2233          ;; Assumes only one assignment
2234          (assert (= (length form) 3))
2235          (try (first args))
2236          (try (second args))
2237          (unless (integerp (second args))
2238            (prune (second args)
2239                   #'(lambda (form)
2240                       (try `(,op ,(first args) ,form))))))
2241
2242         ((rotatef)
2243          (try 0)
2244          (mapc try-fn (cdr form)))
2245
2246         ((multiple-value-setq)
2247          (try 0)
2248          ;; Assumes only one assignment, and one variable
2249          (assert (= (length form) 3))
2250          (assert (= (length (first args)) 1))
2251          (try `(setq ,(caar args) ,(cadr args)))
2252          (unless (integerp (second args))
2253            (prune (second args)
2254                   #'(lambda (form)
2255                       (try `(,op ,(first args) ,form))))))
2256
2257         ((byte)
2258          (prune-fn form try-fn))
2259
2260         ((deposit-field dpb)
2261          (try 0)
2262          (destructuring-bind (a1 a2 a3)
2263              args
2264            (try a1)
2265            (try a3)
2266            (when (and (integerp a1)
2267                       (integerp a3)
2268                       (and (consp a2)
2269                            (eq (first a2) 'byte)
2270                            (integerp (second a2))
2271                            (integerp (third a2))))
2272              (try (eval form))))
2273          (prune-fn form try-fn))
2274
2275         ((ldb mask-field)
2276          (try 0)
2277          (try (second args))
2278          (when (and (consp (first args))
2279                     (eq 'byte (first (first args)))
2280                     (every #'numberp (cdr (first args)))
2281                     (numberp (second args)))
2282            (try (eval form)))
2283          (prune-fn form try-fn))
2284
2285         ((ldb-test)
2286          (try t)
2287          (try nil)
2288          (prune-fn form try-fn))
2289
2290         ((let let*)
2291          (prune-let form try-fn))
2292
2293         ((multiple-value-bind)
2294          (assert (= (length args) 3))
2295          (let ((arg1 (first args))
2296                (arg2 (second args))
2297                (body (caddr args)))
2298            (when (= (length arg1) 1)
2299              (try `(let ((,(first arg1) ,arg2)) ,body)))
2300            (prune arg2 #'(lambda (form)
2301                            (try `(multiple-value-bind ,arg1 ,form ,body))))
2302            (prune body #'(lambda (form)
2303                            (try `(multiple-value-bind ,arg1 ,arg2 ,form))))))
2304
2305         ((block)
2306          (let ((name (second form))
2307                (body (cddr form)))
2308            (when (and body (null (cdr body)))
2309              (let ((form1 (first body)))
2310
2311                ;; Try removing the block entirely if it is not in use
2312                (when (not (find-in-tree name body))
2313                  (try form1))
2314               
2315                ;; Try removing the block if its only use is an immediately
2316                ;; enclosed return-from: (block <n> (return-from <n> <e>))
2317                (when (and (consp form1)
2318                           (eq (first form1) 'return-from)
2319                           (eq (second form1) name)
2320                           (not (find-in-tree name (third form1))))
2321                  (try (third form1)))
2322               
2323                ;; Otherwise, try to simplify the subexpression
2324                (prune form1
2325                       #'(lambda (x)
2326                           (try `(block ,name ,x))))))))
2327
2328         ((catch)
2329          (let* ((tag (second form))
2330                 (name (if (consp tag) (cadr tag) tag))
2331                 (body (cddr form)))
2332            (when (and body (null (cdr body)))
2333              (let ((form1 (first body)))
2334
2335                ;; Try removing the catch entirely if it is not in use
2336                ;; We make assumptions here about what throws can
2337                ;; be present.
2338                (when (or (not (find-in-tree 'throw body))
2339                          (not (find-in-tree name body)))
2340                  (try form1))
2341               
2342                ;; Try removing the block if its only use is an immediately
2343                ;; enclosed return-from: (block <n> (return-from <n> <e>))
2344                (when (and (consp form1)
2345                           (eq (first form1) 'throw)
2346                           (equal (second form1) name)
2347                           (not (find-in-tree name (third form1))))
2348                  (try (third form1)))
2349               
2350                ;; Otherwise, try to simplify the subexpression
2351                (prune form1
2352                       #'(lambda (x)
2353                           (try `(catch ,tag ,x))))))))
2354
2355         ((throw)
2356          (try (second args))
2357          (prune (second args)
2358                 #'(lambda (x) (try `(throw ,(first args) ,x)))))
2359
2360         ((flet labels)
2361          (try 0)
2362          (prune-flet form try-fn))
2363
2364         ((case)
2365          (prune-case form try-fn))
2366
2367         ((isqrt)
2368          (let ((arg (second form)))
2369            (assert (null (cddr form)))
2370            (assert (consp arg))
2371            (assert (eq (first arg) 'abs))
2372            (let ((arg2 (second arg)))
2373              (try arg2)
2374              ;; Try to fold
2375              (when (integerp arg2)
2376                (try (isqrt (abs arg2))))
2377              ;; Otherwise, simplify arg2
2378              (prune arg2 #'(lambda (form)
2379                              (try `(isqrt (abs ,form))))))))
2380
2381         ((ash)
2382          (try 0)
2383          (let ((form1 (second form))
2384                (form2 (third form)))
2385            (try form1)
2386            (try form2)
2387            (prune form1
2388                   #'(lambda (form)
2389                       (try `(ash ,form ,form2))))
2390            (when (and (consp form2)
2391                       (= (length form2) 3))
2392              (when (and (integerp form1)
2393                         (eq (first form2) 'min)
2394                         (every #'integerp (cdr form2)))
2395                (try (eval form)))
2396              (let ((form3 (third form2)))
2397                (prune form3
2398                       #'(lambda (form)
2399                           (try
2400                            `(ash ,form1 (,(first form2) ,(second form2)
2401                                          ,form)))))))))
2402
2403         ((floor ceiling truncate round mod rem)
2404          (try 0)
2405          (let ((form1 (second form))
2406                (form2 (third form)))
2407            (try form1)
2408            (when (cddr form) (try form2))
2409            (prune form1
2410                   (if (cddr form)
2411                       #'(lambda (form)
2412                           (try `(,op ,form ,form2)))
2413                     #'(lambda (form) (try `(,op ,form)))))
2414            (when (and (consp form2)
2415                       (= (length form2) 3))
2416              (when (and (integerp form1)
2417                         (member (first form2) '(max min))
2418                         (every #'integerp (cdr form2)))
2419                (try (eval form)))
2420              (let ((form3 (third form2)))
2421                (prune form3
2422                       #'(lambda (form)
2423                           (try
2424                            `(,op ,form1 (,(first form2) ,(second form2)
2425                                          ,form)))))))))
2426
2427         ((constantly)
2428          (unless (eql (car args) 0)
2429            (prune (car args)
2430                   #'(lambda (arg) (try `(constantly ,arg))))))
2431
2432         ((funcall)
2433          (try 0)
2434          (let ((fn (second form))
2435                (fn-args (cddr form)))
2436            (mapc try-fn fn-args)
2437            (unless (equal fn '(constantly 0))
2438              (try `(funcall (constantly 0) ,@fn-args)))
2439            (when (and (consp fn)
2440                       (eql (car fn) 'function)
2441                       (symbolp (cadr fn)))
2442              (try `(,(cadr fn) ,@fn-args)))
2443            (prune-list fn-args
2444                        #'prune
2445                        #'(lambda (args)
2446                            (try `(funcall ,fn ,@args))))))
2447
2448         ((reduce)
2449          (try 0)
2450          (let ((arg1 (car args))
2451                (arg2 (cadr args))
2452                (rest (cddr args)))
2453            (when (and ;; (null (cddr args))
2454                       (consp arg1)
2455                       (eql (car arg1) 'function))
2456              (let ((arg1.2 (cadr arg1)))
2457                (when (and (consp arg1.2)
2458                           (eql (car arg1.2) 'lambda))
2459                  (let ((largs (cadr arg1.2))
2460                        (body (cddr arg1.2)))
2461                    (when (null (cdr body))
2462                      (prune (car body)
2463                             #'(lambda (bform)
2464                                 (try `(reduce (function (lambda ,largs ,bform))
2465                                               ,arg2 ,@rest)))))))))
2466            (when (consp arg2)
2467              (case (car arg2)
2468                ((list vector)
2469                 (let ((arg2.rest (cdr arg2)))
2470                   (mapc try-fn arg2.rest)
2471                   (prune-list arg2.rest
2472                               #'prune
2473                               #'(lambda (args)
2474                                   (try `(reduce ,arg1
2475                                                 (,(car arg2) ,@args)
2476                                                 ,@rest))))))))))
2477
2478         ((apply)
2479          (try 0)
2480          (let ((fn (second form))
2481                (fn-args (butlast (cddr form)))
2482                (list-arg (car (last form))))
2483            (mapc try-fn fn-args)
2484            (unless (equal fn '(constantly 0))
2485              (try `(apply (constantly 0) ,@(cddr form))))
2486            (when (and (consp list-arg)
2487                       (eq (car list-arg) 'list))
2488              (mapc try-fn (cdr list-arg)))
2489            (prune-list fn-args
2490                        #'prune
2491                        #'(lambda (args)
2492                            (try `(apply ,fn ,@args ,list-arg))))
2493            (when (and (consp list-arg)
2494                       (eq (car list-arg) 'list))
2495              (try `(apply ,fn ,@fn-args ,@(cdr list-arg) nil))
2496              (prune-list (cdr list-arg)
2497                        #'prune
2498                        #'(lambda (args)
2499                            (try `(apply ,fn ,@fn-args
2500                                         (list ,@args))))))))
2501
2502         ((progv)
2503          (try 0)
2504          (prune-progv form try-fn))
2505
2506         ((tagbody)
2507          (try 0)
2508          (prune-tagbody form try-fn))
2509
2510         ((progn)
2511          (when (null args) (try nil))
2512          (try (car (last args)))
2513          (loop for i from 0 below (1- (length args))
2514                for a in args
2515                do (try `(progn ,@(subseq args 0 i)
2516                                ,@(subseq args (1+ i))))
2517                do (when (and (consp a)
2518                              (or
2519                               (eq (car a) 'progn)
2520                               (and (eq (car a) 'tagbody)
2521                                    (every #'consp (cdr a)))))
2522                     (try `(progn ,@(subseq args 0 i)
2523                                  ,@(copy-list (cdr a))
2524                                  ,@(subseq args (1+ i))))))
2525          (prune-fn form try-fn))
2526
2527         ((loop)
2528          (try 0)
2529          (when (and (eql (length args) 6)
2530                     (eql (elt args 0) 'for)
2531                     (eql (elt args 2) 'below))
2532            (let ((var (elt args 1))
2533                  (count (elt args 3))
2534                  (form (elt args 5)))
2535              (unless (eql count 0) (try count))
2536              (case (elt args 4)
2537                (sum
2538                 (try `(let ((,(elt args 1) 0)) ,(elt args 5)))
2539                 (prune form #'(lambda (form)
2540                                 (try `(loop for ,var below ,count sum ,form)))))
2541                (count
2542                 (unless (or (eql form t) (eql form nil))
2543                   (try `(loop for ,var below ,count count t))
2544                   (try `(loop for ,var below ,count count nil))
2545                   (prune form
2546                          #'(lambda (form)
2547                              (try `(loop for ,var below ,count count ,form))))))
2548                ))))
2549
2550         (otherwise
2551          (try 0)
2552          (prune-fn form try-fn))
2553         
2554         )))))
2555  (setf (gethash form *prune-table*) t)
2556  nil)
2557
2558(defun find-in-tree (value tree)
2559  "Return true if VALUE is eql to a node in TREE."
2560  (or (eql value tree)
2561      (and (consp tree)
2562           (or (find-in-tree value (car tree))
2563               (find-in-tree value (cdr tree))))))
2564
2565(defun prune-list (list element-prune-fn list-try-fn)
2566  (declare (type function element-prune-fn list-try-fn))
2567  "Utility function for pruning in a list."
2568    (loop for i from 0
2569          for e in list
2570          do (funcall element-prune-fn
2571                      e
2572                      #'(lambda (form)
2573                          (funcall list-try-fn
2574                                   (append (subseq list 0 i)
2575                                           (list form)
2576                                           (subseq list (1+ i))))))))
2577
2578(defun prune-case (form try-fn)
2579  (declare (type function try-fn))
2580  (flet ((try (e) (funcall try-fn e)))
2581    (let* ((op (first form))
2582           (expr (second form))
2583           (cases (cddr form)))
2584     
2585      ;; Try just the top expression
2586      (try expr)
2587     
2588      ;; Try simplifying the expr
2589      (prune expr
2590             #'(lambda (form)
2591                 (try `(,op ,form ,@cases))))
2592     
2593      ;; Try individual cases
2594      (loop for case in cases
2595            do (try (first (last (rest case)))))
2596     
2597      ;; Try deleting individual cases
2598      (loop for i from 0 below (1- (length cases))
2599            do (try `(,op ,expr
2600                          ,@(subseq cases 0 i)
2601                          ,@(subseq cases (1+ i)))))
2602     
2603      ;; Try simplifying the cases
2604      ;; Assume each case has a single form
2605      (prune-list cases
2606                  #'(lambda (case try-fn)
2607                      (declare (type function try-fn))
2608                      (when (and (listp (car case))
2609                                 (> (length (car case)) 1))
2610                        ;; try removing constants
2611                        (loop for i below (length (car case))
2612                              do (funcall try-fn
2613                                          `((,@(subseq (car case) 0 i)
2614                                             ,@(subseq (car case) (1+ i)))
2615                                            ,@(cdr case)))))
2616                      (when (eql (length case) 2)
2617                        (prune (cadr case)
2618                               #'(lambda (form)
2619                                   (funcall try-fn
2620                                            (list (car case) form))))))
2621                  #'(lambda (cases)
2622                      (try `(,op ,expr ,@cases)))))))
2623
2624(defun prune-tagbody (form try-fn)
2625  (declare (type function try-fn))
2626  (let (;; (op (car form))
2627        (body (cdr form)))
2628    (loop for i from 0
2629          for e in body
2630          do
2631          (cond
2632           ((atom e)
2633            ;; A tag
2634            (unless (find-in-tree e (subseq body 0 i))
2635              (funcall try-fn `(tagbody ,@(subseq body 0 i)
2636                                        ,@(subseq body (1+ i))))))
2637           (t
2638            (funcall try-fn
2639                     `(tagbody ,@(subseq body 0 i)
2640                               ,@(subseq body (1+ i))))
2641            (prune e
2642                   #'(lambda (form)
2643                       ;; Don't put an atom here.
2644                       (when (consp form)
2645                         (funcall
2646                          try-fn
2647                          `(tagbody ,@(subseq body 0 i)
2648                                    ,form
2649                                    ,@(subseq body (1+ i))))))))))))
2650
2651(defun prune-progv (form try-fn)
2652  (declare (type function try-fn))
2653  (let (;; (op (car form))
2654        (vars-form (cadr form))
2655        (vals-form (caddr form))
2656        (body-list (cdddr form)))
2657    (when (and (null vars-form) (null vals-form))
2658      (funcall try-fn `(let () ,@body-list)))
2659    (when (and (consp vals-form) (eql (car vals-form) 'list))
2660      (when (and (consp vars-form) (eql (car vars-form) 'quote))
2661        (let ((vars (cadr vars-form))
2662              (vals (cdr vals-form)))
2663          (when (eql (length vars) (length vals))
2664            (let ((let-form `(let () ,@body-list)))
2665              (mapc #'(lambda (var val)
2666                        (setq let-form `(let ((,var ,val)) ,let-form)))
2667                    vars vals)
2668              (funcall try-fn let-form)))
2669          ;; Try simplifying the vals forms
2670          (prune-list vals
2671                      #'prune
2672                      #'(lambda (vals)
2673                          (funcall try-fn
2674                                   `(progv ,vars-form (list ,@vals) ,@body-list)))))))
2675    ;; Try simplifying the body
2676    (when (eql (length body-list) 1)
2677      (prune (car body-list)
2678             #'(lambda (form)
2679                 (funcall try-fn
2680                          `(progv ,vars-form ,vals-form ,form)))))))
2681
2682(defun prune-nary-fn (form try-fn)
2683  ;; Attempt to reduce the number of arguments to the fn
2684  ;; Do not reduce below 1
2685  (declare (type function try-fn))
2686  (let* ((op (car form))
2687         (args (cdr form))
2688         (nargs (length args)))
2689    (when (> nargs 1)
2690      (loop for i from 1 to nargs
2691            do (funcall try-fn `(,op ,@(subseq args 0 (1- i))
2692                                     ,@(subseq args i)))))))
2693
2694(defun prune-fn (form try-fn)
2695  "Attempt to simplify a function call form.  It is considered
2696   acceptable to replace the call by one of its argument forms."
2697  (declare (type function try-fn))
2698  (prune-list (cdr form)
2699              #'prune
2700              #'(lambda (args)
2701                  (funcall try-fn (cons (car form) args)))))
2702
2703(defun prune-let (form try-fn)
2704  "Attempt to simplify a LET form."
2705  (declare (type function try-fn))
2706  (let* ((op (car form))
2707         (binding-list (cadr form))
2708         (body (cddr form))
2709         (body-len (length body))
2710         (len (length binding-list))
2711         )
2712
2713    (when (> body-len 1)
2714      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
2715
2716    ;; Try to simplify (let ((<name> <form>)) ...) to <form>
2717    #|
2718    (when (and (>= len 1)
2719               ;; (eql body-len 1)
2720               ;; (eql (caar binding-list) (car body))
2721               )
2722      (let ((val-form (cadar binding-list)))
2723        (unless (and (consp val-form)
2724                     (eql (car val-form) 'make-array))
2725          (funcall try-fn val-form))))
2726    |#
2727
2728    (when (>= len 1)
2729      (let ((val-form (cadar binding-list)))
2730        (when (consp val-form)
2731          (case (car val-form)
2732            ((make-array)
2733             (let ((init (getf (cddr val-form) :initial-element)))
2734               (when init
2735                 (funcall try-fn init))))
2736            ((cons)
2737             (funcall try-fn (cadr val-form))
2738             (funcall try-fn (caddr val-form)))))))
2739
2740    ;; Try to simplify the forms in the RHS of the bindings
2741    (prune-list binding-list
2742                #'(lambda (binding try-fn)
2743                    (declare (type function try-fn))
2744                    (prune (cadr binding)
2745                           #'(lambda (form)
2746                               (funcall try-fn
2747                                        (list (car binding)
2748                                              form)))))
2749                #'(lambda (bindings)
2750                    (funcall try-fn `(,op ,bindings ,@body))))
2751
2752    ;; Prune off unused variable
2753    (when (and binding-list
2754               (not (rest binding-list))
2755               (let ((name (caar binding-list)))
2756                 (and (symbolp name)
2757                      (not (find-if-subtree #'(lambda (x) (eq x name)) body)))))
2758      (funcall try-fn `(progn ,@body)))
2759
2760    ;; Try to simplify the body of the LET form
2761    (when body
2762      (unless binding-list
2763        (funcall try-fn (car (last body))))
2764      (when (and (first binding-list)
2765                 (not (rest binding-list))
2766                 (not (rest body)))
2767        (let ((binding (first binding-list)))
2768          (unless (or (consp (second binding))
2769                      (has-binding-to-var (first binding) body)
2770                      (has-assignment-to-var (first binding) body)
2771                      )
2772            (funcall try-fn `(let ()
2773                               ,@(subst (second binding)
2774                                        (first binding)
2775                                        (remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
2776                                                   body)
2777                                        ))))))
2778      (prune (car (last body))
2779             #'(lambda (form2)
2780                 (funcall try-fn
2781                          `(,@(butlast form) ,form2)))))))
2782
2783(defun has-assignment-to-var (var form)
2784  (find-if-subtree
2785   #'(lambda (form)
2786       (and (consp form)
2787            (or
2788             (and (member (car form) '(setq setf shiftf incf decf) :test #'eq)
2789                  (eq (cadr form) var))
2790             (and (eql (car form) 'multiple-value-setq)
2791                  (member var (cadr form))))))
2792   form))
2793
2794(defun has-binding-to-var (var form)
2795  (find-if-subtree
2796   #'(lambda (form)
2797       (and (consp form)
2798            (case (car form)
2799              ((let let*)
2800               (loop for binding in (cadr form)
2801                     thereis (eq (car binding) var)))
2802              ((progv)
2803               (and (consp (cadr form))
2804                    (eq (caadr form) 'quote)
2805                    (consp (second (cadr form)))
2806                    (member var (second (cadr form)))))
2807              (t nil))))
2808   form))
2809
2810(defun find-if-subtree (pred tree)
2811  (declare (type function pred))
2812  (cond
2813   ((funcall pred tree) tree)
2814   ((consp tree)
2815    (or (find-if-subtree pred (car tree))
2816        (find-if-subtree pred (cdr tree))))
2817   (t nil)))
2818
2819(defun prune-flet (form try-fn)
2820  "Attempt to simplify a FLET form."
2821  (declare (type function try-fn))
2822
2823  (let* ((op (car form))
2824         (binding-list (cadr form))
2825         (body (cddr form)))
2826
2827    ;; Remove a declaration, if any
2828    (when (and (consp body)
2829               (consp (car body))
2830               (eq (caar body) 'declare))
2831      (funcall try-fn `(,op ,binding-list ,@(cdr body))))
2832
2833    ;; Try to prune optional arguments
2834    (prune-list binding-list
2835                #'(lambda (binding try-fn)
2836                    (declare (type function try-fn))
2837                    (let* ((name (car binding))
2838                           (args (cadr binding))
2839                           (body (cddr binding))
2840                           (opt-pos (position-if #'(lambda (e) (member e '(&key &optional)))
2841                                                 (the list args))))
2842                      (when opt-pos
2843                        (incf opt-pos)
2844                        (let ((normal-args (subseq args 0 (1- opt-pos)))
2845                              (optionals (subseq args opt-pos)))
2846                          (prune-list optionals
2847                                      #'(lambda (opt-lambda-arg try-fn)
2848                                          (declare (type function try-fn))
2849                                          (when (consp opt-lambda-arg)
2850                                            (let ((name (first opt-lambda-arg))
2851                                                  (form (second opt-lambda-arg)))
2852                                              (prune form
2853                                                     #'(lambda (form)
2854                                                         (funcall try-fn (list name form)))))))
2855                                      #'(lambda (opt-args)
2856                                          (funcall try-fn
2857                                                   `(,name (,@normal-args
2858                                                              &optional
2859                                                              ,@opt-args)
2860                                                           ,@body))))))))
2861                #'(lambda (bindings)
2862                    (funcall try-fn `(,op ,bindings ,@body))))
2863                       
2864   
2865    ;; Try to simplify the forms in the RHS of the bindings
2866    (prune-list binding-list
2867                #'(lambda (binding try-fn)
2868                    (declare (type function try-fn))
2869                     
2870                    ;; Prune body of a binding
2871                    (prune (third binding)
2872                           #'(lambda (form)
2873                               (funcall try-fn
2874                                        (list (first binding)
2875                                              (second binding)
2876                                              form)))))
2877                #'(lambda (bindings)
2878                    (funcall try-fn `(,op ,bindings ,@body))))
2879
2880    ;; ;; Try to simplify the body of the FLET form
2881    (when body
2882
2883      ;; No bindings -- try to simplify to the last form in the body
2884      (unless binding-list
2885        (funcall try-fn (first (last body))))
2886
2887      (when (and (consp binding-list)
2888                 (null (rest binding-list)))
2889        (let ((binding (first binding-list)))
2890          ;; One binding -- match on (flet ((<name> () <body>)) (<name>))
2891          (when (and (symbolp (first binding))
2892                     (not (find-in-tree (first binding) (rest binding)))
2893                     (null (second binding))
2894                     (equal body (list (list (first binding)))))
2895            (funcall try-fn `(,op () ,@(cddr binding))))
2896          ;; One binding -- try to remove it if not used
2897          (when (and (symbolp (first binding))
2898                     (not (find-in-tree (first binding) body)))
2899            (funcall try-fn (first (last body))))
2900        ))
2901
2902
2903      ;; Try to simplify (the last form in) the body.
2904      (prune (first (last body))
2905             #'(lambda (form2)
2906                 (funcall try-fn
2907                          `(,@(butlast form) ,form2)))))))
2908
2909;;; Routine to walk form, applying a function at each form
2910;;; The fn is applied in preorder.  When it returns :stop, do
2911;;; not descend into subforms
2912
2913#|
2914(defun walk (form fn)
2915  (declare (type function fn))
2916  (unless (eq (funcall fn form) :stop)
2917    (when (consp form)
2918      (let ((op (car form)))
2919        (case op
2920          ((let let*)
2921           (walk-let form fn))
2922          ((cond)
2923           (dolist (clause (cdr form))
2924             (walk-implicit-progn clause fn)))
2925          ((multiple-value-bind)
2926              (walk (third form) fn)
2927              (walk-body (cdddr form) fn))
2928          ((function quote declare) nil)
2929          ((block the return-from)
2930           (walk-implicit-progn (cddr form) fn))
2931          ((case typecase)
2932           (walk (cadr form) fn)
2933           (dolist (clause (cddr form))
2934             (walk-implicit-progn (cdr clause) fn)))
2935          ((flet labels)
2936           
2937         
2938             
2939         
2940|# 
2941
2942;;;;;;;;;;;;;;;;;;;;;;
2943;;; Convert pruned results to test cases
2944
2945(defun produce-test-cases (instances &key
2946                                     (stream *standard-output*)
2947                                     (prefix "MISC.")
2948                                     (index 1))
2949  (dolist (inst instances)
2950    (let* (;; (vars (getf inst :vars))
2951           (vals (getf inst :vals))
2952           (optimized-lambda-form (getf inst :optimized-lambda-form))
2953           (unoptimized-lambda-form (getf inst :unoptimized-lambda-form))
2954           (name (intern
2955                  (concatenate 'string prefix (format nil "~D" index))
2956                  "CL-TEST"))
2957           (test-form
2958            `(deftest ,name
2959               (let* ((fn1 ',optimized-lambda-form)
2960                      (fn2 ',unoptimized-lambda-form)
2961                      (vals ',vals)
2962                      (v1 (apply (compile nil fn1) vals))
2963                      (v2 (apply (compile nil fn2) vals)))
2964                 (if (eql v1 v2)
2965                     :good
2966                   (list v1 v2)))
2967               :good)))
2968      (print test-form stream)
2969      (terpri stream)
2970      (incf index)))
2971  (values))
Note: See TracBrowser for help on using the repository browser.