/[gcl]/gcl/ansi-tests/random-int-form.lsp
ViewVC logotype

Contents of /gcl/ansi-tests/random-int-form.lsp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (show annotations) (download)
Sun Feb 26 02:41:23 2006 UTC (18 years, 1 month ago) by pfdietz
Branch: MAIN
CVS Tags: HEAD
Branch point for: std-build, experimental
Changes since 1.61: +583 -268 lines
Redo make-random-element-of-type to use generic functions.
Fix some bugs in make-random-string.
Begin adding random type prop tests for structure accessors.

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))

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26