Skip to content
Snippets Groups Projects
Commit 94e6fe23 authored by pfdietz's avatar pfdietz
Browse files

Some minor extensions.

Routines for making random symbols.
Add option for compiling as a generic function.
Get rid of some armedbear conditionalizations.
Tweak some distributions to favor smaller values (quadratically).
This makes some name-name collisions more common.
parent 42047cda
No related branches found
No related tags found
No related merge requests found
...@@ -108,7 +108,7 @@ ...@@ -108,7 +108,7 @@
(defvar *random-int-form-catch-tags* nil) (defvar *random-int-form-catch-tags* nil)
(defvar *go-tags* nil) (defvar *go-tags* nil)
(defvar *maximum-random-int-bits* 45) (defvar *maximum-random-int-bits* 36)
(defvar *random-vals-list-bound* 10) (defvar *random-vals-list-bound* 10)
...@@ -267,14 +267,18 @@ ...@@ -267,14 +267,18 @@
(defparameter *flet-names* nil) (defparameter *flet-names* nil)
(defun make-random-integer () (defun make-random-integer ()
(let ((r (ash 1 (1+ (random 32))))) (let ((r (ash 1 (1+ (random *maximum-random-int-bits*)))))
(- (random r) (floor (/ r 2))))) (rcase
(6 (- (random r) (floor (/ r 2))))
(1 (- r (random (min 10 r))))
(1 (+ (floor (/ r 2)) (random (min 10 r)))))))
(defun make-random-rational () (defun make-random-rational ()
(let* ((r (ash 1 (1+ (random 32)))) (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*))))
(n (random r)) (n (random r)))
(d (loop for x = (random r) unless (zerop x) do (return x)))) (assert (>= r 2))
(if (coin) (/ n d) (- (/ n d))))) (let ((d (loop for x = (random r) unless (zerop x) do (return x))))
(if (coin) (/ n d) (- (/ n d))))))
(defun make-random-float () (defun make-random-float ()
(rcase (rcase
...@@ -283,6 +287,12 @@ ...@@ -283,6 +287,12 @@
(1 (random most-positive-double-float)) (1 (random most-positive-double-float))
(1 (random most-positive-long-float)))) (1 (random most-positive-long-float))))
(defun make-random-symbol ()
(rcase
(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)))
(2 (random-from-seq *cl-symbols-vector*))
(1 (gensym))))
(defun random-var-desc () (defun random-var-desc ()
(loop (loop
(let* ((pos (random (length *vars*))) (let* ((pos (random (length *vars*)))
...@@ -342,7 +352,7 @@ ...@@ -342,7 +352,7 @@
;; flet call ;; flet call
;; #-(or armedbear) ;; #-(or armedbear)
(30 ;; 5 (10
(make-random-integer-flet-call-form size)) (make-random-integer-flet-call-form size))
(5 (make-random-aref-form size)) (5 (make-random-aref-form size))
...@@ -353,7 +363,8 @@ ...@@ -353,7 +363,8 @@
rational rationalize rational rationalize
numerator denominator numerator denominator
identity progn floor identity progn floor
#-(or armedbear) ignore-errors ;; #-(or armedbear)
ignore-errors
cl:handler-case cl:handler-case
restart-case restart-case
ceiling truncate round realpart imagpart ceiling truncate round realpart imagpart
...@@ -368,7 +379,6 @@ ...@@ -368,7 +379,6 @@
(5 (make-random-integer-mapping-form size)) (5 (make-random-integer-mapping-form size))
;; prog1, multiple-value-prog1 ;; prog1, multiple-value-prog1
#-(or armedbear)
(4 (4
(let* ((op (random-from-seq #(prog1 multiple-value-prog1))) (let* ((op (random-from-seq #(prog1 multiple-value-prog1)))
(nforms (random 4)) (nforms (random 4))
...@@ -384,11 +394,15 @@ ...@@ -384,11 +394,15 @@
(2 `(isqrt (abs ,(make-random-integer-form (- size 2))))) (2 `(isqrt (abs ,(make-random-integer-form (- size 2)))))
(2 `(the integer ,(make-random-integer-form (1- size)))) ;; #-armedbear
(10 `(the integer ,(make-random-integer-form (1- size))))
(1 `(cl:handler-bind nil ,(make-random-integer-form (1- size)))) (1 `(cl:handler-bind nil ,(make-random-integer-form (1- size))))
(1 `(restart-bind nil ,(make-random-integer-form (1- size)))) (1 `(restart-bind nil ,(make-random-integer-form (1- size))))
#-armedbear (1 `(macrolet () ,(make-random-integer-form (1- size)))) #-armedbear
(1 `(macrolet () ,(make-random-integer-form (1- size))))
#-armedbear
(1 `(symbol-macrolet () ,(make-random-integer-form (1- size))))
;; dotimes ;; dotimes
#-allegro #-allegro
...@@ -447,7 +461,7 @@ ...@@ -447,7 +461,7 @@
;; Binary op ;; Binary op
(30 (30
(let* ((op (random-from-seq (let* ((op (random-from-seq
'(+ - * logand min max gcd '(+ - * logand min max gcd
lcm lcm
#-:allegro #-:allegro
...@@ -480,8 +494,8 @@ ...@@ -480,8 +494,8 @@
(40 (40
(let* ((op (random-from-seq #(+ - * logand min max (let* ((op (random-from-seq #(+ - * logand min max
logior values lcm gcd logxor))) logior values lcm gcd logxor)))
(nmax (case op ((* lcm gcd) 10) (t 20))) (nmax (case op ((* lcm gcd) 4) (t (1+ (random 40)))))
(nargs (1+ (min (random nmax) (random nmax) (random nmax)))) (nargs (1+ (min (random nmax) (random nmax))))
(sizes (random-partition (1- size) nargs)) (sizes (random-partition (1- size) nargs))
(args (mapcar #'make-random-integer-form sizes))) (args (mapcar #'make-random-integer-form sizes)))
`(,op ,@args))) `(,op ,@args)))
...@@ -503,7 +517,7 @@ ...@@ -503,7 +517,7 @@
(5 (make-random-tagbody-and-progn size)) (5 (make-random-tagbody-and-progn size))
;; conditionals ;; conditionals
(100 (30
(let* ((cond-size (random (max 1 (floor size 2)))) (let* ((cond-size (random (max 1 (floor size 2))))
(then-size (random (- size cond-size))) (then-size (random (- size cond-size)))
(else-size (- size 1 cond-size then-size)) (else-size (- size 1 cond-size then-size))
...@@ -526,7 +540,7 @@ ...@@ -526,7 +540,7 @@
,(make-random-byte-spec-form s1) ,(make-random-byte-spec-form s1)
,(make-random-integer-form s2)))) ,(make-random-integer-form s2))))
(20 (make-random-integer-binding-form size)) (50 (make-random-integer-binding-form size))
;; progv ;; progv
#-(or armedbear) #-(or armedbear)
...@@ -539,13 +553,12 @@ ...@@ -539,13 +553,12 @@
(*random-int-form-blocks* (adjoin name *random-int-form-blocks*))) (*random-int-form-blocks* (adjoin name *random-int-form-blocks*)))
`(block ,name ,(make-random-integer-form (1- size))))) `(block ,name ,(make-random-integer-form (1- size)))))
#-armedbear
(20 (20
(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))))
(*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*)))
`(catch ,tag ,(make-random-integer-form (1- size))))) `(catch ,tag ,(make-random-integer-form (1- size)))))
(20 ;; setq and similar (10 ;; setq and similar
(make-random-integer-setq-form size)) (make-random-integer-setq-form size))
(10 (make-random-integer-case-form size)) (10 (make-random-integer-case-form size))
...@@ -730,11 +743,17 @@ ...@@ -730,11 +743,17 @@
'(cons integer integer))))) '(cons integer integer)))))
e1))) e1)))
(defun random2 (n)
(min (random n) (random n)))
(defun random-from-seq2 (seq)
(elt seq (random2 (length seq))))
(defun make-random-integer-binding-form (size) (defun make-random-integer-binding-form (size)
(destructuring-bind (s1 s2) (random-partition (1- size) 2) (destructuring-bind (s1 s2) (random-partition (1- size) 2)
(let* ((var (rcase (let* ((var (random-from-seq2 (rcase
(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))
(2 (random-from-seq *random-special-vars*)))) (2 *random-special-vars*))))
(e1 (make-random-integer-form s1)) (e1 (make-random-integer-form s1))
(type (multiple-value-bind (type2 e) (type (multiple-value-bind (type2 e)
(make-random-type-for-var var e1) (make-random-type-for-var var e1)
...@@ -750,7 +769,7 @@ ...@@ -750,7 +769,7 @@
(rcase (rcase
(8 `(,op ((,var ,e1)) (8 `(,op ((,var ,e1))
,@(rcase (1 `((declare (dynamic-extent ,var)))) ,@(rcase (1 `((declare (dynamic-extent ,var))))
(1 nil)) (3 nil))
,e2)) ,e2))
(2 `(multiple-value-bind (,var) ,e1 ,e2))))))) (2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
...@@ -804,7 +823,7 @@ ...@@ -804,7 +823,7 @@
,@(mapcar #'make-random-integer-form sizes)) ,@(mapcar #'make-random-integer-form sizes))
,@keyargs))) ,@keyargs)))
#-(or armedbear) #-(or armedbear)
(1 (1
(destructuring-bind (size1 size2) (random-partition (1- size) 2) (destructuring-bind (size1 size2) (random-partition (1- size) 2)
(let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6))
(var1 (random-from-seq vars)) (var1 (random-from-seq vars))
...@@ -1105,6 +1124,9 @@ ...@@ -1105,6 +1124,9 @@
((consp type) ((consp type)
(let ((type-op (first type))) (let ((type-op (first type)))
(ecase type-op (ecase type-op
(or
(assert (cdr type))
(make-random-element-of-type (random-from-seq (cdr type))))
(integer (integer
(let ((lo (let ((lo (cadr type))) (let ((lo (let ((lo (cadr type)))
(cond (cond
...@@ -1145,6 +1167,12 @@ ...@@ -1145,6 +1167,12 @@
(assert (and (integerp bits) (>= bits 1))) (assert (and (integerp bits) (>= bits 1)))
(make-random-element-of-type (make-random-element-of-type
`(integer 0 ,(1- (ash 1 bits))))))))) `(integer 0 ,(1- (ash 1 bits)))))))))
(eql
(assert (= (length type) 2))
(cadr type))
(member
(assert (cdr type))
(random-from-seq (cdr type)))
))) )))
(t (t
(ecase type (ecase type
...@@ -1153,6 +1181,7 @@ ...@@ -1153,6 +1181,7 @@
(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)))
(unsigned-byte (random-from-interval (unsigned-byte (random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*))) 0)) (1+ (ash 1 (random *maximum-random-int-bits*))) 0))
(rational (locally (declare (notinline make-random-rational)) (make-random-rational)))
(integer (let ((x (ash 1 (random *maximum-random-int-bits*)))) (integer (let ((x (ash 1 (random *maximum-random-int-bits*))))
(random-from-interval (1+ x) (- x)))) (random-from-interval (1+ x) (- x))))
)))) ))))
...@@ -1177,6 +1206,11 @@ ...@@ -1177,6 +1206,11 @@
(defvar *compile-using-defun* (defvar *compile-using-defun*
#-(or allegro lispworks) nil #-(or allegro lispworks) nil
#+(or allegro lispworks) t) #+(or allegro lispworks) t)
(defvar *compile-using-defgeneric* nil
"If true and *COMPILE-USING-DEFUN* is false, then build a defgeneric form
for the function and compile that.")
(defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1) (defvar *name-to-use-in-optimized-defun* 'dummy-fn-name1)
(defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2) (defvar *name-to-use-in-unoptimized-defun* 'dummy-fn-name2)
...@@ -1195,7 +1229,8 @@ ...@@ -1195,7 +1229,8 @@
(cl:handler-bind (cl:handler-bind
(#+sbcl (sb-ext::compiler-note #'muffle-warning) (#+sbcl (sb-ext::compiler-note #'muffle-warning)
(warning #'muffle-warning) (warning #'muffle-warning)
(error #'(lambda (c) ((or error serious-condition)
#'(lambda (c)
(format t "Compilation failure~%~A~%" (format t "Compilation failure~%~A~%"
(format nil "~S" form)) (format nil "~S" form))
(finish-output *standard-output*) (finish-output *standard-output*)
...@@ -1211,15 +1246,23 @@ ...@@ -1211,15 +1246,23 @@
(with-output-to-string (with-output-to-string
(s) (s)
(prin1 c s)))))))) (prin1 c s))))))))
(let ((start-time (get-universal-time))) (let ((start-time (get-universal-time))
(clf (cdr lambda-form)))
(prog1 (prog1
(if *compile-using-defun* (cond
(progn (*compile-using-defun*
(eval `(defun ,opt-defun-name (fmakunbound opt-defun-name)
,@(cdr lambda-form))) (eval `(defun ,opt-defun-name ,@clf))
(compile opt-defun-name) (compile opt-defun-name)
(symbol-function opt-defun-name)) (symbol-function opt-defun-name))
(compile nil lambda-form)) (*compile-using-defgeneric*
(fmakunbound opt-defun-name)
(eval `(defgeneric ,opt-defun-name ,(car clf)))
(eval `(defmethod ,opt-defun-name,(mapcar #'(lambda (name) `(,name integer)) (car clf))
,@(cdr clf)))
(compile opt-defun-name)
(symbol-function opt-defun-name))
(t (compile nil lambda-form)))
(let* ((stop-time (get-universal-time)) (let* ((stop-time (get-universal-time))
(total-time (- stop-time start-time))) (total-time (- stop-time start-time)))
(when (> total-time *max-compile-time*) (when (> total-time *max-compile-time*)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment