108 |
(defvar *random-int-form-catch-tags* nil) |
(defvar *random-int-form-catch-tags* nil) |
109 |
(defvar *go-tags* nil) |
(defvar *go-tags* nil) |
110 |
|
|
111 |
(defvar *maximum-random-int-bits* 45) |
(defvar *maximum-random-int-bits* 36) |
112 |
|
|
113 |
(defvar *random-vals-list-bound* 10) |
(defvar *random-vals-list-bound* 10) |
114 |
|
|
267 |
(defparameter *flet-names* nil) |
(defparameter *flet-names* nil) |
268 |
|
|
269 |
(defun make-random-integer () |
(defun make-random-integer () |
270 |
(let ((r (ash 1 (1+ (random 32))))) |
(let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) |
271 |
(- (random r) (floor (/ r 2))))) |
(rcase |
272 |
|
(6 (- (random r) (floor (/ r 2)))) |
273 |
|
(1 (- r (random (min 10 r)))) |
274 |
|
(1 (+ (floor (/ r 2)) (random (min 10 r))))))) |
275 |
|
|
276 |
(defun make-random-rational () |
(defun make-random-rational () |
277 |
(let* ((r (ash 1 (1+ (random 32)))) |
(let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) |
278 |
(n (random r)) |
(n (random r))) |
279 |
(d (loop for x = (random r) unless (zerop x) do (return x)))) |
(assert (>= r 2)) |
280 |
(if (coin) (/ n d) (- (/ n d))))) |
(let ((d (loop for x = (random r) unless (zerop x) do (return x)))) |
281 |
|
(if (coin) (/ n d) (- (/ n d)))))) |
282 |
|
|
283 |
(defun make-random-float () |
(defun make-random-float () |
284 |
(rcase |
(rcase |
287 |
(1 (random most-positive-double-float)) |
(1 (random most-positive-double-float)) |
288 |
(1 (random most-positive-long-float)))) |
(1 (random most-positive-long-float)))) |
289 |
|
|
290 |
|
(defun make-random-symbol () |
291 |
|
(rcase |
292 |
|
(3 (random-from-seq #(a b c d e f g h i j k l m n o p q r s t u v w x y z))) |
293 |
|
(2 (random-from-seq *cl-symbols-vector*)) |
294 |
|
(1 (gensym)))) |
295 |
|
|
296 |
(defun random-var-desc () |
(defun random-var-desc () |
297 |
(loop |
(loop |
298 |
(let* ((pos (random (length *vars*))) |
(let* ((pos (random (length *vars*))) |
352 |
|
|
353 |
;; flet call |
;; flet call |
354 |
;; #-(or armedbear) |
;; #-(or armedbear) |
355 |
(30 ;; 5 |
(10 |
356 |
(make-random-integer-flet-call-form size)) |
(make-random-integer-flet-call-form size)) |
357 |
|
|
358 |
(5 (make-random-aref-form size)) |
(5 (make-random-aref-form size)) |
363 |
rational rationalize |
rational rationalize |
364 |
numerator denominator |
numerator denominator |
365 |
identity progn floor |
identity progn floor |
366 |
#-(or armedbear) ignore-errors |
;; #-(or armedbear) |
367 |
|
ignore-errors |
368 |
cl:handler-case |
cl:handler-case |
369 |
restart-case |
restart-case |
370 |
ceiling truncate round realpart imagpart |
ceiling truncate round realpart imagpart |
379 |
(5 (make-random-integer-mapping-form size)) |
(5 (make-random-integer-mapping-form size)) |
380 |
|
|
381 |
;; prog1, multiple-value-prog1 |
;; prog1, multiple-value-prog1 |
|
#-(or armedbear) |
|
382 |
(4 |
(4 |
383 |
(let* ((op (random-from-seq #(prog1 multiple-value-prog1))) |
(let* ((op (random-from-seq #(prog1 multiple-value-prog1))) |
384 |
(nforms (random 4)) |
(nforms (random 4)) |
394 |
|
|
395 |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) |
396 |
|
|
397 |
(2 `(the integer ,(make-random-integer-form (1- size)))) |
;; #-armedbear |
398 |
|
(10 `(the integer ,(make-random-integer-form (1- size)))) |
399 |
|
|
400 |
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) |
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) |
401 |
(1 `(restart-bind nil ,(make-random-integer-form (1- size)))) |
(1 `(restart-bind nil ,(make-random-integer-form (1- size)))) |
402 |
#-armedbear (1 `(macrolet () ,(make-random-integer-form (1- size)))) |
#-armedbear |
403 |
|
(1 `(macrolet () ,(make-random-integer-form (1- size)))) |
404 |
|
#-armedbear |
405 |
|
(1 `(symbol-macrolet () ,(make-random-integer-form (1- size)))) |
406 |
|
|
407 |
;; dotimes |
;; dotimes |
408 |
#-allegro |
#-allegro |
461 |
|
|
462 |
;; Binary op |
;; Binary op |
463 |
(30 |
(30 |
464 |
(let* ((op (random-from-seq |
(let* ((op (random-from-seq |
465 |
'(+ - * logand min max gcd |
'(+ - * logand min max gcd |
466 |
lcm |
lcm |
467 |
#-:allegro |
#-:allegro |
494 |
(40 |
(40 |
495 |
(let* ((op (random-from-seq #(+ - * logand min max |
(let* ((op (random-from-seq #(+ - * logand min max |
496 |
logior values lcm gcd logxor))) |
logior values lcm gcd logxor))) |
497 |
(nmax (case op ((* lcm gcd) 10) (t 20))) |
(nmax (case op ((* lcm gcd) 4) (t (1+ (random 40))))) |
498 |
(nargs (1+ (min (random nmax) (random nmax) (random nmax)))) |
(nargs (1+ (min (random nmax) (random nmax)))) |
499 |
(sizes (random-partition (1- size) nargs)) |
(sizes (random-partition (1- size) nargs)) |
500 |
(args (mapcar #'make-random-integer-form sizes))) |
(args (mapcar #'make-random-integer-form sizes))) |
501 |
`(,op ,@args))) |
`(,op ,@args))) |
517 |
(5 (make-random-tagbody-and-progn size)) |
(5 (make-random-tagbody-and-progn size)) |
518 |
|
|
519 |
;; conditionals |
;; conditionals |
520 |
(100 |
(30 |
521 |
(let* ((cond-size (random (max 1 (floor size 2)))) |
(let* ((cond-size (random (max 1 (floor size 2)))) |
522 |
(then-size (random (- size cond-size))) |
(then-size (random (- size cond-size))) |
523 |
(else-size (- size 1 cond-size then-size)) |
(else-size (- size 1 cond-size then-size)) |
540 |
,(make-random-byte-spec-form s1) |
,(make-random-byte-spec-form s1) |
541 |
,(make-random-integer-form s2)))) |
,(make-random-integer-form s2)))) |
542 |
|
|
543 |
(20 (make-random-integer-binding-form size)) |
(50 (make-random-integer-binding-form size)) |
544 |
|
|
545 |
;; progv |
;; progv |
546 |
#-(or armedbear) |
#-(or armedbear) |
553 |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) |
554 |
`(block ,name ,(make-random-integer-form (1- size))))) |
`(block ,name ,(make-random-integer-form (1- size))))) |
555 |
|
|
|
#-armedbear |
|
556 |
(20 |
(20 |
557 |
(let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) |
(let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) |
558 |
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) |
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) |
559 |
`(catch ,tag ,(make-random-integer-form (1- size))))) |
`(catch ,tag ,(make-random-integer-form (1- size))))) |
560 |
|
|
561 |
(20 ;; setq and similar |
(10 ;; setq and similar |
562 |
(make-random-integer-setq-form size)) |
(make-random-integer-setq-form size)) |
563 |
|
|
564 |
(10 (make-random-integer-case-form size)) |
(10 (make-random-integer-case-form size)) |
743 |
'(cons integer integer))))) |
'(cons integer integer))))) |
744 |
e1))) |
e1))) |
745 |
|
|
746 |
|
(defun random2 (n) |
747 |
|
(min (random n) (random n))) |
748 |
|
|
749 |
|
(defun random-from-seq2 (seq) |
750 |
|
(elt seq (random2 (length seq)))) |
751 |
|
|
752 |
(defun make-random-integer-binding-form (size) |
(defun make-random-integer-binding-form (size) |
753 |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
(destructuring-bind (s1 s2) (random-partition (1- size) 2) |
754 |
(let* ((var (rcase |
(let* ((var (random-from-seq2 (rcase |
755 |
(2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10))) |
(2 #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)) |
756 |
(2 (random-from-seq *random-special-vars*)))) |
(2 *random-special-vars*)))) |
757 |
(e1 (make-random-integer-form s1)) |
(e1 (make-random-integer-form s1)) |
758 |
(type (multiple-value-bind (type2 e) |
(type (multiple-value-bind (type2 e) |
759 |
(make-random-type-for-var var e1) |
(make-random-type-for-var var e1) |
769 |
(rcase |
(rcase |
770 |
(8 `(,op ((,var ,e1)) |
(8 `(,op ((,var ,e1)) |
771 |
,@(rcase (1 `((declare (dynamic-extent ,var)))) |
,@(rcase (1 `((declare (dynamic-extent ,var)))) |
772 |
(1 nil)) |
(3 nil)) |
773 |
,e2)) |
,e2)) |
774 |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) |
775 |
|
|
823 |
,@(mapcar #'make-random-integer-form sizes)) |
,@(mapcar #'make-random-integer-form sizes)) |
824 |
,@keyargs))) |
,@keyargs))) |
825 |
#-(or armedbear) |
#-(or armedbear) |
826 |
(1 |
(1 |
827 |
(destructuring-bind (size1 size2) (random-partition (1- size) 2) |
(destructuring-bind (size1 size2) (random-partition (1- size) 2) |
828 |
(let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) |
(let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) |
829 |
(var1 (random-from-seq vars)) |
(var1 (random-from-seq vars)) |
1124 |
((consp type) |
((consp type) |
1125 |
(let ((type-op (first type))) |
(let ((type-op (first type))) |
1126 |
(ecase type-op |
(ecase type-op |
1127 |
|
(or |
1128 |
|
(assert (cdr type)) |
1129 |
|
(make-random-element-of-type (random-from-seq (cdr type)))) |
1130 |
(integer |
(integer |
1131 |
(let ((lo (let ((lo (cadr type))) |
(let ((lo (let ((lo (cadr type))) |
1132 |
(cond |
(cond |
1167 |
(assert (and (integerp bits) (>= bits 1))) |
(assert (and (integerp bits) (>= bits 1))) |
1168 |
(make-random-element-of-type |
(make-random-element-of-type |
1169 |
`(integer 0 ,(1- (ash 1 bits))))))))) |
`(integer 0 ,(1- (ash 1 bits))))))))) |
1170 |
|
(eql |
1171 |
|
(assert (= (length type) 2)) |
1172 |
|
(cadr type)) |
1173 |
|
(member |
1174 |
|
(assert (cdr type)) |
1175 |
|
(random-from-seq (cdr type))) |
1176 |
))) |
))) |
1177 |
(t |
(t |
1178 |
(ecase type |
(ecase type |
1181 |
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) |
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car))) |
1182 |
(unsigned-byte (random-from-interval |
(unsigned-byte (random-from-interval |
1183 |
(1+ (ash 1 (random *maximum-random-int-bits*))) 0)) |
(1+ (ash 1 (random *maximum-random-int-bits*))) 0)) |
1184 |
|
(rational (locally (declare (notinline make-random-rational)) (make-random-rational))) |
1185 |
(integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) |
(integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) |
1186 |
(random-from-interval (1+ x) (- x)))) |
(random-from-interval (1+ x) (- x)))) |
1187 |
)))) |
)))) |
1206 |
(defvar *compile-using-defun* |
(defvar *compile-using-defun* |
1207 |
#-(or allegro lispworks) nil |
#-(or allegro lispworks) nil |
1208 |
#+(or allegro lispworks) t) |
#+(or allegro lispworks) t) |
1209 |
|
|
1210 |
|
(defvar *compile-using-defgeneric* nil |
1211 |
|
"If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form |
1212 |
|
for the function and compile that.") |
1213 |
|
|
1214 |
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) |
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) |
1215 |
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) |
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) |
1216 |
|
|
1229 |
(cl:handler-bind |
(cl:handler-bind |
1230 |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
(#+sbcl (sb-ext::compiler-note #'muffle-warning) |
1231 |
(warning #'muffle-warning) |
(warning #'muffle-warning) |
1232 |
(error #'(lambda (c) |
((or error serious-condition) |
1233 |
|
#'(lambda (c) |
1234 |
(format t "Compilation failure~%~A~%" |
(format t "Compilation failure~%~A~%" |
1235 |
(format nil "~S" form)) |
(format nil "~S" form)) |
1236 |
(finish-output *standard-output*) |
(finish-output *standard-output*) |
1246 |
(with-output-to-string |
(with-output-to-string |
1247 |
(s) |
(s) |
1248 |
(prin1 c s)))))))) |
(prin1 c s)))))))) |
1249 |
(let ((start-time (get-universal-time))) |
(let ((start-time (get-universal-time)) |
1250 |
|
(clf (cdr lambda-form))) |
1251 |
(prog1 |
(prog1 |
1252 |
(if *compile-using-defun* |
(cond |
1253 |
(progn |
(*compile-using-defun* |
1254 |
(eval `(defun ,opt-defun-name |
(fmakunbound opt-defun-name) |
1255 |
,@(cdr lambda-form))) |
(eval `(defun ,opt-defun-name ,@clf)) |
1256 |
(compile opt-defun-name) |
(compile opt-defun-name) |
1257 |
(symbol-function opt-defun-name)) |
(symbol-function opt-defun-name)) |
1258 |
(compile nil lambda-form)) |
(*compile-using-defgeneric* |
1259 |
|
(fmakunbound opt-defun-name) |
1260 |
|
(eval `(defgeneric ,opt-defun-name ,(car clf))) |
1261 |
|
(eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf)) |
1262 |
|
,@(cdr clf))) |
1263 |
|
(compile opt-defun-name) |
1264 |
|
(symbol-function opt-defun-name)) |
1265 |
|
(t (compile nil lambda-form))) |
1266 |
(let* ((stop-time (get-universal-time)) |
(let* ((stop-time (get-universal-time)) |
1267 |
(total-time (- stop-time start-time))) |
(total-time (- stop-time start-time))) |
1268 |
(when (> total-time *max-compile-time*) |
(when (> total-time *max-compile-time*) |