55 |
(when x |
(when x |
56 |
(setq $x (append $x x)) |
(setq $x (append $x x)) |
57 |
(setq x (prune-results x)) |
(setq x (prune-results x)) |
58 |
(terpri) (print x) |
(terpri) (print x) (finish-output *standard-output*) |
59 |
(setq $y (append $y x))) |
(setq $y (append $y x))) |
60 |
(terpri)))) |
(terpri)))) |
61 |
|
|
94 |
|
|
95 |
(loop for i from 1 to n |
(loop for i from 1 to n |
96 |
do (when (= (mod i 100) 0) |
do (when (= (mod i 100) 0) |
97 |
#+sbcl (sb-ext::gc) |
#+sbcl (sb-ext::gc :full t) |
98 |
(prin1 i) (princ " ") (finish-output *standard-output*)) |
(prin1 i) (princ " ") (finish-output *standard-output*)) |
99 |
nconc (let ((result (test-random-integer-form size nvars))) |
nconc (let ((result (test-random-integer-form size nvars))) |
100 |
(when result |
(when result |
177 |
|
|
178 |
(if (<= size 1) |
(if (<= size 1) |
179 |
;; Leaf node -- generate a variable, constant, or flet function call |
;; Leaf node -- generate a variable, constant, or flet function call |
180 |
(rcase |
(loop |
181 |
(10 (make-random-integer)) |
when |
182 |
(9 (if *vars* (var-desc-name (random-from-seq *vars*)) |
(rcase |
183 |
(make-random-integer-form size))) |
(10 (make-random-integer)) |
184 |
(1 (if *flet-names* |
(9 (if *vars* (var-desc-name (random-from-seq *vars*)) |
185 |
(let* ((flet-entry (random-from-seq *flet-names*)) |
nil)) |
186 |
(flet-name (car flet-entry)) |
(2 (if *flet-names* |
187 |
(flet-minargs (cadr flet-entry)) |
(let* ((flet-entry (random-from-seq *flet-names*)) |
188 |
(flet-maxargs (caddr flet-entry)) |
(flet-name (car flet-entry)) |
189 |
(nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) |
(flet-minargs (cadr flet-entry)) |
190 |
(args (loop repeat nargs |
(flet-maxargs (caddr flet-entry)) |
191 |
collect (make-random-integer-form 1)))) |
(nargs (random-from-interval (1+ flet-maxargs) flet-minargs)) |
192 |
`(,flet-name ,@args)) |
(args (loop repeat nargs |
193 |
(make-random-integer-form size)))) |
collect (make-random-integer-form 1)))) |
194 |
|
`(,flet-name ,@args)) |
195 |
|
nil))) |
196 |
|
return it) |
197 |
;; (> size 1) |
;; (> size 1) |
198 |
(rcase |
(rcase |
199 |
;; flet call |
;; flet call |
200 |
(5 |
(30 ;; 5 |
201 |
(if *flet-names* |
(if *flet-names* |
202 |
(let* ((flet-entry (random-from-seq *flet-names*)) |
(let* ((flet-entry (random-from-seq *flet-names*)) |
203 |
(flet-name (car flet-entry)) |
(flet-name (car flet-entry)) |
211 |
(args (mapcar #'make-random-integer-form arg-sizes))) |
(args (mapcar #'make-random-integer-form arg-sizes))) |
212 |
(rcase |
(rcase |
213 |
(1 `(,flet-name ,@args)) |
(1 `(,flet-name ,@args)) |
214 |
(1 `(multiple-value-call #',flet-name (values ,@args)))))) |
(1 `(multiple-value-call #',flet-name (values ,@args))) |
215 |
|
(1 `(funcall (function ,flet-name) ,@args)) |
216 |
|
(1 (let ((r (random (1+ (length args))))) |
217 |
|
`(apply (function ,flet-name) |
218 |
|
,@(subseq args 0 r) |
219 |
|
(list ,@(subseq args r)))))))) |
220 |
(t (make-random-integer-form size)))) |
(t (make-random-integer-form size)))) |
221 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
222 |
|
|
375 |
;; No blocks -- try again |
;; No blocks -- try again |
376 |
(make-random-integer-form size))) |
(make-random-integer-form size))) |
377 |
|
|
378 |
(10 (make-random-flet-form size)) |
(50 ;; 10 |
379 |
|
(make-random-flet-form size)) |
380 |
|
|
381 |
))) |
))) |
382 |
|
|
625 |
(error #'(lambda (c) |
(error #'(lambda (c) |
626 |
(format t "Compilation failure~%") |
(format t "Compilation failure~%") |
627 |
(print form) |
(print form) |
628 |
|
(finish-output *standard-output*) |
629 |
(return-from test-int-form |
(return-from test-int-form |
630 |
(list (list :vars vars |
(list (list :vars vars |
631 |
:form form |
:form form |
665 |
(flet ((%eval-error |
(flet ((%eval-error |
666 |
(kind) |
(kind) |
667 |
(print form) |
(print form) |
668 |
|
(finish-output *standard-output*) |
669 |
(return |
(return |
670 |
(list (list :vars vars |
(list (list :vars vars |
671 |
:vals vals |
:vals vals |
700 |
|
|
701 |
;;; Interface to the form pruner |
;;; Interface to the form pruner |
702 |
|
|
703 |
(defun prune-int-form (form vars var-types vals-list) |
(declaim (special *prune-table*)) |
704 |
"Conduct tests on selected simplified versions of FORM. Return the |
|
705 |
|
(defun prune-int-form (input-form vars var-types vals-list) |
706 |
|
"Conduct tests on selected simplified versions of INPUT-FORM. Return the |
707 |
minimal form that still causes some kind of failure." |
minimal form that still causes some kind of failure." |
708 |
(flet ((%try-fn (new-form) |
(loop do |
709 |
(when (test-int-form new-form vars var-types vals-list) |
(let ((form input-form)) |
710 |
(setf form new-form) |
(flet ((%try-fn (new-form) |
711 |
(throw 'success nil)))) |
(when (test-int-form new-form vars var-types vals-list) |
712 |
(loop |
(setf form new-form) |
713 |
(catch 'success |
(throw 'success nil)))) |
714 |
(prune form #'%try-fn) |
(let ((*prune-table* (make-hash-table :test #'eq))) |
715 |
(return form))))) |
(loop |
716 |
|
(catch 'success |
717 |
|
(prune form #'%try-fn) |
718 |
|
(return form))))) |
719 |
|
(when (equal form input-form) (return form)) |
720 |
|
(setq input-form form)))) |
721 |
|
|
722 |
(defun prune-results (result-list) |
(defun prune-results (result-list) |
723 |
"Given a list of test results, prune their forms down to a minimal set." |
"Given a list of test results, prune their forms down to a minimal set." |
749 |
;;; |
;;; |
750 |
(defun prune (form try-fn) |
(defun prune (form try-fn) |
751 |
(declare (type function try-fn)) |
(declare (type function try-fn)) |
752 |
|
(when (gethash form *prune-table*) |
753 |
|
(return-from prune nil)) |
754 |
(flet ((try (x) (funcall try-fn x))) |
(flet ((try (x) (funcall try-fn x))) |
755 |
(when (consp form) |
(when (consp form) |
756 |
(let* ((op (car form)) |
(let* ((op (car form)) |
768 |
|
|
769 |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
((abs 1+ 1- identity values progn prog1 multiple-value-prog1 unwind-protect |
770 |
ignore-errors cl:handler-case restart-case locally) |
ignore-errors cl:handler-case restart-case locally) |
771 |
(mapc #'try args) |
(mapc try-fn args) |
772 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
773 |
|
|
774 |
((typep) |
((typep) |
793 |
((the macrolet cl:handler-bind) |
((the macrolet cl:handler-bind) |
794 |
(assert (= (length args) 2)) |
(assert (= (length args) 2)) |
795 |
(try (second args)) |
(try (second args)) |
796 |
(prune (second args) #'try)) |
(prune (second args) try-fn)) |
797 |
|
|
798 |
((not eq eql equal) |
((not eq eql equal) |
799 |
(when (every #'constantp args) |
(when (every #'constantp args) |
800 |
(try (eval form))) |
(try (eval form))) |
801 |
(mapc #'try args) |
(mapc try-fn args) |
802 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
803 |
|
|
804 |
((- + * min max logand logior logxor logeqv |
((- + * min max logand logior logxor logeqv |
805 |
and or = < > <= >= /=) |
and or = < > <= >= /=) |
806 |
(when (every #'constantp args) |
(when (every #'constantp args) |
807 |
(try (eval form))) |
(try (eval form))) |
808 |
(mapc #'try args) |
(mapc try-fn args) |
809 |
(prune-nary-fn form try-fn) |
(prune-nary-fn form try-fn) |
810 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
811 |
|
|
816 |
(when (and (consp arg1) (consp arg2) |
(when (and (consp arg1) (consp arg2) |
817 |
(eql (first arg1) 'function) |
(eql (first arg1) 'function) |
818 |
(eql (first arg2) 'values)) |
(eql (first arg2) 'values)) |
819 |
(mapc #'try (rest arg2)) |
(mapc try-fn (rest arg2)) |
820 |
(let ((fn (second arg1))) |
(let ((fn (second arg1))) |
821 |
(when (symbolp fn) |
(when (symbolp fn) |
822 |
(try `(,fn ,@(rest arg2))))) |
(try `(,fn ,@(rest arg2))))) |
826 |
#'(lambda (args) |
#'(lambda (args) |
827 |
(try `(multiple-value-call ,arg1 (values ,@args))))) |
(try `(multiple-value-call ,arg1 (values ,@args))))) |
828 |
))) |
))) |
829 |
(mapc #'try (rest args))) |
(mapc try-fn (rest args))) |
830 |
|
|
831 |
((if) |
((if) |
832 |
(let (;; (pred (first args)) |
(let (;; (pred (first args)) |
833 |
(then (second args)) |
(then (second args)) |
976 |
(try |
(try |
977 |
`(,op ,form1 (,(first form2) ,(second form2) |
`(,op ,form1 (,(first form2) ,(second form2) |
978 |
,form))))))))) |
,form))))))))) |
979 |
|
|
980 |
|
((funcall) |
981 |
|
(let ((fn (second form)) |
982 |
|
(fn-args (cddr form))) |
983 |
|
(mapc try-fn fn-args) |
984 |
|
(when (and (consp fn) |
985 |
|
(eql (car fn) 'function) |
986 |
|
(symbolp (cadr fn))) |
987 |
|
(try `(,(cadr fn) ,@fn-args))) |
988 |
|
(prune-list fn-args |
989 |
|
#'prune |
990 |
|
#'(lambda (args) |
991 |
|
(funcall try-fn `(funcall ,fn ,@args)))))) |
992 |
|
|
993 |
|
((apply) |
994 |
|
(let ((fn (second form)) |
995 |
|
(fn-args (butlast (cddr form))) |
996 |
|
(list-arg (car (last form)))) |
997 |
|
(mapc try-fn fn-args) |
998 |
|
(when (and (consp list-arg) |
999 |
|
(eq (car list-arg) 'list)) |
1000 |
|
(mapc try-fn (cdr list-arg))) |
1001 |
|
(prune-list fn-args |
1002 |
|
#'prune |
1003 |
|
#'(lambda (args) |
1004 |
|
(funcall try-fn `(apply ,fn ,@args ,list-arg)))) |
1005 |
|
(when (and (consp list-arg) |
1006 |
|
(eq (car list-arg) 'list)) |
1007 |
|
(prune-list (cdr list-arg) |
1008 |
|
#'prune |
1009 |
|
#'(lambda (args) |
1010 |
|
(funcall try-fn `(apply ,fn ,@fn-args |
1011 |
|
(list ,@args)))))))) |
1012 |
|
|
1013 |
(otherwise |
(otherwise |
1014 |
(prune-fn form try-fn)) |
(prune-fn form try-fn)) |
1015 |
))))) |
)))) |
1016 |
|
(setf (gethash form *prune-table*) t) |
1017 |
|
nil) |
1018 |
|
|
1019 |
(defun find-in-tree (value tree) |
(defun find-in-tree (value tree) |
1020 |
"Return true if VALUE is eql to a node in TREE." |
"Return true if VALUE is eql to a node in TREE." |
1131 |
(not (rest body))) |
(not (rest body))) |
1132 |
(let ((binding (first binding-list))) |
(let ((binding (first binding-list))) |
1133 |
(unless (or (consp (second binding)) |
(unless (or (consp (second binding)) |
1134 |
|
(has-binding-to-var (first binding) body) |
1135 |
(has-assignment-to-var (first binding) body)) |
(has-assignment-to-var (first binding) body)) |
1136 |
(funcall try-fn `(let () |
(funcall try-fn `(let () |
1137 |
,@(subst (second binding) |
,@(subst (second binding) |
1142 |
`(,@(butlast form) ,form2))))))) |
`(,@(butlast form) ,form2))))))) |
1143 |
|
|
1144 |
(defun has-assignment-to-var (var form) |
(defun has-assignment-to-var (var form) |
1145 |
(when (consp form) |
(find-if-subtree |
1146 |
(or (and (member (car form) '(setq setf)) |
#'(lambda (form) |
1147 |
(eq (cadr form) var)) |
(and (consp form) |
1148 |
(loop for subform in form |
(member (car form) '(setq setf) :test #'eq) |
1149 |
thereis (has-assignment-to-var var subform))))) |
(eq (cadr form) var))) |
1150 |
|
form)) |
1151 |
|
|
1152 |
|
(defun has-binding-to-var (var form) |
1153 |
|
(find-if-subtree |
1154 |
|
#'(lambda (form) |
1155 |
|
(and (consp form) |
1156 |
|
(member (car form) '(let let*) :test #'eq) |
1157 |
|
(loop for binding in (cadr form) |
1158 |
|
thereis (eq (car binding) var)))) |
1159 |
|
form)) |
1160 |
|
|
1161 |
|
(defun find-if-subtree (pred tree) |
1162 |
|
(declare (type function pred)) |
1163 |
|
(cond |
1164 |
|
((funcall pred tree) tree) |
1165 |
|
((consp tree) |
1166 |
|
(or (find-if-subtree pred (car tree)) |
1167 |
|
(find-if-subtree pred (cdr tree)))) |
1168 |
|
(t nil))) |
1169 |
|
|
1170 |
(defun prune-flet (form try-fn) |
(defun prune-flet (form try-fn) |
1171 |
"Attempt to simplify a FLET form." |
"Attempt to simplify a FLET form." |