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