127 |
(y (- (random b) b2))) |
(y (- (random b) b2))) |
128 |
(list (min x y) (max x y))))))) |
(list (min x y) (max x y))))))) |
129 |
|
|
130 |
|
(defun fn-arg-name (fn-name arg-index) |
131 |
|
(intern (concatenate 'string |
132 |
|
(subseq (symbol-name fn-name) 1) |
133 |
|
(format nil "-~D" arg-index)) |
134 |
|
(symbol-package fn-name))) |
135 |
|
|
136 |
(defparameter *flet-names* nil) |
(defparameter *flet-names* nil) |
137 |
|
|
138 |
(defun make-random-integer-form (size) |
(defun make-random-integer-form (size) |
143 |
(rcase |
(rcase |
144 |
(10 (let ((r (ash 1 (1+ (random 32))))) |
(10 (let ((r (ash 1 (1+ (random 32))))) |
145 |
(- (random r) (floor (/ r 2))))) |
(- (random r) (floor (/ r 2))))) |
146 |
(9 (var-desc-name (random-from-seq *vars*))) |
(9 (if *vars* (var-desc-name (random-from-seq *vars*)) |
147 |
(1 (if *flet-names* (list (random-from-seq *flet-names*)) |
(make-random-integer-form size))) |
148 |
(var-desc-name (random-from-seq *vars*))))) |
(1 (if *flet-names* |
149 |
|
(let* ((flet-entry (random-from-seq *flet-names*)) |
150 |
|
(flet-name (car flet-entry)) |
151 |
|
(flet-nargs (cadr flet-entry)) |
152 |
|
(args (loop repeat flet-nargs |
153 |
|
collect (make-random-integer-form 1)))) |
154 |
|
`(,flet-name ,@args)) |
155 |
|
(make-random-integer-form size)))) |
156 |
;; (> size 1) |
;; (> size 1) |
157 |
(rcase |
(rcase |
158 |
|
;; flet call |
159 |
|
(5 |
160 |
|
(if *flet-names* |
161 |
|
(let* ((flet-entry (random-from-seq *flet-names*)) |
162 |
|
(flet-name (car flet-entry)) |
163 |
|
(flet-nargs (cadr flet-entry))) |
164 |
|
(if (> flet-nargs 0) |
165 |
|
(let* ((arg-sizes (random-partition (1- size) flet-nargs)) |
166 |
|
(args (mapcar #'make-random-integer-form arg-sizes))) |
167 |
|
`(,flet-name ,@args)) |
168 |
|
(make-random-integer-form size))) |
169 |
|
(make-random-integer-form size))) |
170 |
|
|
171 |
;; Unary ops |
;; Unary ops |
172 |
(40 |
(40 |
173 |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor |
(let ((op (random-from-seq '(- abs signum 1+ 1- identity progn floor ignore-errors |
174 |
|
handler-case restart-case |
175 |
ceiling truncate round realpart imagpart |
ceiling truncate round realpart imagpart |
176 |
integer-length logcount values multiple-value-prog1 |
integer-length logcount values multiple-value-prog1 |
177 |
prog1 unwind-protect)))) |
prog1 unwind-protect locally)))) |
178 |
`(,op ,(make-random-integer-form (1- size))))) |
`(,op ,(make-random-integer-form (1- size))))) |
179 |
|
|
180 |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
181 |
|
|
182 |
|
(2 `(the integer ,(make-random-integer-form (1- size)))) |
183 |
|
(1 `(handler-bind nil ,(make-random-integer-form (1- size)))) |
184 |
|
(1 `(macrolet () ,(make-random-integer-form (1- size)))) |
185 |
|
|
186 |
|
;; load-time-value |
187 |
|
#-gcl |
188 |
|
(4 |
189 |
|
(let ((arg (let ((*flet-names* nil) |
190 |
|
(*vars* nil) |
191 |
|
(*random-int-form-blocks* nil)) |
192 |
|
(make-random-integer-form (1- size))))) |
193 |
|
(rcase |
194 |
|
(2 `(load-time-value ,arg t)) |
195 |
|
(1 `(load-time-value ,arg)) |
196 |
|
(1 `(load-time-value ,arg nil))))) |
197 |
|
|
198 |
|
#-(or cmu allegro) |
199 |
(2 |
(2 |
200 |
(destructuring-bind (s1 s2) |
(destructuring-bind (s1 s2) |
201 |
(random-partition (- size 2) 2) |
(random-partition (- size 2) 2) |
216 |
,(make-random-integer-form s2)))))) |
,(make-random-integer-form s2)))))) |
217 |
|
|
218 |
;; Binary op |
;; Binary op |
219 |
(60 |
(30 |
220 |
(let* ((op (random-from-seq |
(let* ((op (random-from-seq |
221 |
'(+ - * * logand min max min max ;; gcd lcm |
'(+ - * logand min max gcd ;; lcm |
222 |
;; #-:allegro |
#-:allegro |
223 |
logandc1 |
logandc1 |
224 |
logandc2 logeqv logior lognand lognor |
logandc2 logeqv logior lognand lognor |
225 |
;; #-:allegro |
#-:allegro |
226 |
logorc1 |
logorc1 |
227 |
logorc2 logxor)))) |
logorc2 |
228 |
|
#-:allegro |
229 |
|
logxor |
230 |
|
)))) |
231 |
(destructuring-bind (leftsize rightsize) |
(destructuring-bind (leftsize rightsize) |
232 |
(random-partition (1- size) 2) |
(random-partition (1- size) 2) |
233 |
(let ((e1 (make-random-integer-form leftsize)) |
(let ((e1 (make-random-integer-form leftsize)) |
234 |
(e2 (make-random-integer-form rightsize))) |
(e2 (make-random-integer-form rightsize))) |
235 |
`(,op ,e1 ,e2))))) |
`(,op ,e1 ,e2))))) |
236 |
|
|
237 |
|
;; n-ary ops |
238 |
|
(30 |
239 |
|
(let* ((op (random-from-seq #(+ - * logand min max logior |
240 |
|
#-:allegro |
241 |
|
logxor))) |
242 |
|
(nargs (1+ (random 8))) |
243 |
|
(sizes (random-partition (1- size) nargs)) |
244 |
|
(args (mapcar #'make-random-integer-form sizes))) |
245 |
|
`(,op ,@args))) |
246 |
|
|
247 |
;; conditionals |
;; conditionals |
248 |
(20 |
(20 |
249 |
(let* ((cond-size (random (max 1 (floor size 2)))) |
(let* ((cond-size (random (max 1 (floor size 2)))) |
259 |
,(make-random-integer-form s1) |
,(make-random-integer-form s1) |
260 |
,(make-random-byte-spec-form s2) |
,(make-random-byte-spec-form s2) |
261 |
,(make-random-integer-form s3)))) |
,(make-random-integer-form s3)))) |
262 |
;; #-:allegro |
#-:allegro |
263 |
(10 |
(10 |
264 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
265 |
`(,(random-from-seq '(ldb mask-field)) |
`(,(random-from-seq '(ldb mask-field)) |
283 |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
284 |
`(block ,name ,(make-random-integer-form (1- size))))) |
`(block ,name ,(make-random-integer-form (1- size))))) |
285 |
(4 ;; setq |
(4 ;; setq |
286 |
(let* ((vdesc (random-from-seq *vars*)) |
(if *vars* |
287 |
(var (var-desc-name vdesc)) |
(let* ((vdesc (random-from-seq *vars*)) |
288 |
(type (var-desc-type vdesc))) |
(var (var-desc-name vdesc)) |
289 |
(cond |
(type (var-desc-type vdesc))) |
290 |
((equal type '(integer * *)) |
(cond |
291 |
`(setq ,var ,(make-random-integer-form (1- size)))) |
((equal type '(integer * *)) |
292 |
((and (consp type) |
`(setq ,var ,(make-random-integer-form (1- size)))) |
293 |
(eq (car type) 'integer) |
((and (consp type) |
294 |
(integerp (second type)) |
(eq (car type) 'integer) |
295 |
(integerp (third type))) |
(integerp (second type)) |
296 |
`(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) |
(integerp (third type))) |
297 |
(t (make-random-integer-form size))))) |
`(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) |
298 |
|
(t (make-random-integer-form size)))) |
299 |
|
(make-random-integer-form size))) |
300 |
|
|
301 |
(3 (make-random-integer-case-form size)) |
(3 (make-random-integer-case-form size)) |
302 |
(3 |
(3 |
352 |
and a single binding per form." |
and a single binding per form." |
353 |
(let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 |
(let ((fname (random-from-seq #(%f1 %f2 %f3 %f4 %f5 %f6 %f7 %f8 %f9 %f10 |
354 |
%f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) |
%f11 %f12 %f13 %f14 %f15 %f16 %f17 %f18)))) |
355 |
(if (member fname *flet-names* :test #'eq) |
(if (assoc fname *flet-names*) |
356 |
(make-random-integer-form size) |
(make-random-integer-form size) |
357 |
(destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2) |
(destructuring-bind (s1 s2) (random-partition (max 2 (1- size)) 2) |
358 |
(let ((op (random-from-seq #(flet labels))) |
(let* ((op (random-from-seq #(flet labels))) |
359 |
(form1 |
(nargs (random 4)) |
360 |
;; Allow return-from of the flet/labels function |
(arg-names (loop for i from 1 to nargs |
361 |
(let ((*random-int-form-blocks* |
collect (fn-arg-name fname i))) |
362 |
(cons fname *random-int-form-blocks*))) |
(form1 |
363 |
(make-random-integer-form s1))) |
;; Allow return-from of the flet/labels function |
364 |
(form2 (let ((*flet-names* (cons fname *flet-names*))) |
(let ((*random-int-form-blocks* |
365 |
(make-random-integer-form s2)))) |
(cons fname *random-int-form-blocks*)) |
366 |
`(,op ((,fname () ,form1)) ,form2)))))) |
(*vars* (nconc (loop for var in arg-names |
367 |
|
collect (make-var-desc :name var |
368 |
|
:type '(integer * *))) |
369 |
|
*vars*))) |
370 |
|
(make-random-integer-form s1))) |
371 |
|
(form2 (let ((*flet-names* (cons (list fname nargs) |
372 |
|
*flet-names*))) |
373 |
|
(make-random-integer-form s2)))) |
374 |
|
`(,op ((,fname ,arg-names ,form1)) ,form2)))))) |
375 |
|
|
376 |
(defun make-random-pred-form (size) |
(defun make-random-pred-form (size) |
377 |
"Make a random form whose value is to be used as a generalized boolean." |
"Make a random form whose value is to be used as a generalized boolean." |
520 |
(declare (optimize (debug 0))) |
(declare (optimize (debug 0))) |
521 |
,form)) |
,form)) |
522 |
|
|
523 |
|
(defvar *compile-using-defun* #-(or allegro lispworks) nil #+(or allegro lispworks) t) |
524 |
|
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) |
525 |
|
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) |
526 |
|
|
527 |
(defun test-int-form (form vars var-types vals-list) |
(defun test-int-form (form vars var-types vals-list) |
528 |
;; Try to compile FORM with associated VARS, and if it compiles |
;; Try to compile FORM with associated VARS, and if it compiles |
529 |
;; check for equality of the two compiled forms. |
;; check for equality of the two compiled forms. |
535 |
*optimized-fn-src* optimized-fn-src |
*optimized-fn-src* optimized-fn-src |
536 |
*unoptimized-fn-src* unoptimized-fn-src) |
*unoptimized-fn-src* unoptimized-fn-src) |
537 |
(flet ((%compile |
(flet ((%compile |
538 |
(lambda-form) |
(lambda-form opt-defun-name) |
539 |
(handler-bind |
(handler-bind |
540 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
541 |
(warning #'muffle-warning) |
(warning #'muffle-warning) |
552 |
(*standard-output*) |
(*standard-output*) |
553 |
(let ((*print-escape* t)) |
(let ((*print-escape* t)) |
554 |
(prin1 c))))))))) |
(prin1 c))))))))) |
555 |
(prog1 (compile nil lambda-form) |
(prog1 |
556 |
|
(if *compile-using-defun* |
557 |
|
(progn |
558 |
|
(eval `(defun ,opt-defun-name |
559 |
|
,@(cdr lambda-form))) |
560 |
|
(compile opt-defun-name) |
561 |
|
(symbol-function opt-defun-name)) |
562 |
|
(compile nil lambda-form)) |
563 |
#+:ecl (si:gc t) |
#+:ecl (si:gc t) |
564 |
)))) |
)))) |
565 |
(let ((optimized-compiled-fn (%compile optimized-fn-src)) |
(let ((optimized-compiled-fn (%compile optimized-fn-src |
566 |
|
*name-to-use-in-optimized-defun*)) |
567 |
(unoptimized-compiled-fn |
(unoptimized-compiled-fn |
568 |
(if *compile-unoptimized-form* |
(if *compile-unoptimized-form* |
569 |
(%compile unoptimized-fn-src) |
(%compile unoptimized-fn-src *name-to-use-in-unoptimized-defun*) |
570 |
(eval `(function ,unoptimized-fn-src))))) |
(eval `(function ,unoptimized-fn-src))))) |
571 |
(declare (type function optimized-compiled-fn unoptimized-compiled-fn)) |
(declare (type function optimized-compiled-fn unoptimized-compiled-fn)) |
572 |
(dolist (vals vals-list) |
(dolist (vals vals-list) |
663 |
(try -1) |
(try -1) |
664 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
665 |
|
|
666 |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect) |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
667 |
|
ignore-errors handler-case restart-case locally) |
668 |
|
(mapc #'try args) |
669 |
|
(prune-fn form try-fn)) |
670 |
|
|
671 |
|
((load-time-value) |
672 |
|
(let ((arg (first args))) |
673 |
|
(try arg) |
674 |
|
(cond |
675 |
|
((cdr args) |
676 |
|
(try `(load-time-value ,arg)) |
677 |
|
(prune arg |
678 |
|
#'(lambda (form) |
679 |
|
(try `(load-time-value ,form ,(second args)))))) |
680 |
|
(t |
681 |
|
(prune arg |
682 |
|
#'(lambda (form) |
683 |
|
(try `(load-time-value ,form)))))))) |
684 |
|
|
685 |
|
((the macrolet handler-bind) |
686 |
|
(assert (= (length args) 2)) |
687 |
|
(try (second args)) |
688 |
|
(prune (second args) |
689 |
|
#'(lambda (form) (try `(the ,(first args) ,form))))) |
690 |
|
|
691 |
|
((not eq eql equal) |
692 |
|
(when (every #'constantp args) |
693 |
|
(try (eval form))) |
694 |
(mapc #'try args) |
(mapc #'try args) |
695 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
696 |
|
|
697 |
((- + * min max logand logior logxor logeqv |
((- + * min max logand logior logxor logeqv |
698 |
and or not eq eql equal = < > <= >= /=) |
and or = < > <= >= /=) |
699 |
(when (every #'constantp args) |
(when (every #'constantp args) |
700 |
(try (eval form))) |
(try (eval form))) |
701 |
(mapc #'try args) |
(mapc #'try args) |
702 |
|
(prune-nary-fn form try-fn) |
703 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
704 |
|
|
705 |
((if) |
((if) |
901 |
#'(lambda (cases) |
#'(lambda (cases) |
902 |
(try `(,op ,expr ,@cases))))))) |
(try `(,op ,expr ,@cases))))))) |
903 |
|
|
904 |
|
(defun prune-nary-fn (form try-fn) |
905 |
|
;; Attempt to reduce the number of arguments to the fn |
906 |
|
;; Do not reduce below 1 |
907 |
|
(let* ((op (car form)) |
908 |
|
(args (cdr form)) |
909 |
|
(nargs (length args))) |
910 |
|
(when (> nargs 1) |
911 |
|
(loop for i from 1 to nargs |
912 |
|
do (funcall try-fn `(,op ,@(subseq args 0 (1- i)) |
913 |
|
,@(subseq args i))))))) |
914 |
|
|
915 |
(defun prune-fn (form try-fn) |
(defun prune-fn (form try-fn) |
916 |
"Attempt to simplify a function call form. It is considered |
"Attempt to simplify a function call form. It is considered |
917 |
acceptable to replace the call by one of its argument forms." |
acceptable to replace the call by one of its argument forms." |
1022 |
#'(lambda (form2) |
#'(lambda (form2) |
1023 |
(funcall try-fn |
(funcall try-fn |
1024 |
`(,@(butlast form) ,form2))))))) |
`(,@(butlast form) ,form2))))))) |
1025 |
|
|
1026 |
|
;;;;;;;;;;;;;;;;;;;;;; |
1027 |
|
;;; Convert pruned results to test cases |
1028 |
|
|
1029 |
|
(defun produce-test-cases (instances &key |
1030 |
|
(stream *standard-output*) |
1031 |
|
(prefix "MISC.") |
1032 |
|
(index 1)) |
1033 |
|
(dolist (inst instances) |
1034 |
|
(let* (;; (vars (getf inst :vars)) |
1035 |
|
(vals (getf inst :vals)) |
1036 |
|
(optimized-lambda-form (getf inst :optimized-lambda-form)) |
1037 |
|
(unoptimized-lambda-form (getf inst :unoptimized-lambda-form)) |
1038 |
|
(name (intern |
1039 |
|
(concatenate 'string prefix (format nil "~D" index)) |
1040 |
|
"CL-TEST")) |
1041 |
|
(test-form |
1042 |
|
`(deftest ,name |
1043 |
|
(let* ((fn1 ',optimized-lambda-form) |
1044 |
|
(fn2 ',unoptimized-lambda-form) |
1045 |
|
(vals ',vals) |
1046 |
|
(v1 (apply (compile nil fn1) vals)) |
1047 |
|
(v2 (apply (compile nil fn2) vals))) |
1048 |
|
(if (eql v1 v2) |
1049 |
|
:good |
1050 |
|
(list v1 v2))) |
1051 |
|
:good))) |
1052 |
|
(print test-form stream) |
1053 |
|
(terpri stream) |
1054 |
|
(incf index))) |
1055 |
|
(values)) |
1056 |
|
|
1057 |
|
|
1058 |
|
|
1059 |
|
|
1060 |
|
|
1061 |
|
|
1062 |
|
|
1063 |
|
|