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