Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
ansi-test
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
Karsten Poeck
ansi-test
Commits
d1359565
Commit
d1359565
authored
Nov 29, 2004
by
pfdietz
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Minor refactoring and added some better pruning rules.
parent
f1cb0eda
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
74 additions
and
28 deletions
+74
-28
ansi-tests/random-int-form.lsp
ansi-tests/random-int-form.lsp
+74
-28
No files found.
ansi-tests/random-int-form.lsp
View file @
d1359565
...
...
@@ -72,8 +72,17 @@
(declaim (special *s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
(defparameter *random-special-vars*
#(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*))
(defparameter *loop-random-int-form-period* 2000)
(defmacro cl-handler-bind (&rest args)
`(cl:handler-bind ,@args))
(defmacro cl-handler-case (&rest args)
`(cl:handler-case ,@args))
;;; Run the random tester, collecting failures into the special
;;; variable $y.
...
...
@@ -144,6 +153,7 @@
do (when (= (mod i 100) 0)
;; #+sbcl (print "Do gc...")
;; #+sbcl (sb-ext::gc :full t)
;; #+lispworks-personal-edition (cl-user::normal-gc)
(prin1 i) (princ " ") (finish-output *standard-output*))
nconc (let ((result (test-random-integer-form
(if random-size (1+ (random size)) size)
...
...
@@ -208,7 +218,7 @@
(defun make-random-optimize-settings ()
(loop for settings = (list*
(list 'speed (random 4))
;
#+sbcl '(sb-c:insert-step-conditions 0)
#+sbcl '(sb-c:insert-step-conditions 0)
(loop for s in '(space safety debug compilation-speed)
for n = (random 4)
collect (list s n)))
...
...
@@ -344,7 +354,8 @@
numerator denominator
identity progn floor
#-(or armedbear) ignore-errors
cl:handler-case restart-case
cl:handler-case
restart-case
ceiling truncate round realpart imagpart
integer-length logcount values
locally))))
...
...
@@ -414,7 +425,7 @@
;; eval
(2 (make-random-integer-eval-form size))
#-(or cmu allegro)
#-(or cmu allegro
poplog
)
(20
(destructuring-bind (s1 s2)
(random-partition (- size 2) 2)
...
...
@@ -491,7 +502,7 @@
(5 (make-random-tagbody-and-progn size))
;; conditionals
(
2
0
(
10
0
(let* ((cond-size (random (max 1 (floor size 2))))
(then-size (random (- size cond-size)))
(else-size (- size 1 cond-size then-size))
...
...
@@ -499,6 +510,7 @@
(then-part (make-random-integer-form then-size))
(else-part (make-random-integer-form else-size)))
`(if ,pred ,then-part ,else-part)))
#-poplog
(5
(destructuring-bind (s1 s2 s3) (random-partition (1- size) 3)
`(,(random-from-seq '(deposit-field dpb))
...
...
@@ -506,7 +518,7 @@
,(make-random-byte-spec-form s2)
,(make-random-integer-form s3))))
#-
:allegro
#-
(or allegro poplog)
(10
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
`(,(random-from-seq '(ldb mask-field))
...
...
@@ -674,10 +686,8 @@
(flet ((%arg (size)
(let ((*flet-names* nil)
(*vars* (remove-if-not #'(lambda (s)
(member (var-desc-name s)
'(*s1* *s2* *s3* *s4* *s5*
*s6* *s7* *s8* *s9*)
:test #'eq))
(find (var-desc-name s)
*random-special-vars*))
*vars*))
(*random-int-form-blocks* nil)
(*go-tags* nil))
...
...
@@ -694,7 +704,7 @@
(let (desc)
(values
(cond
((and (
member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq
)
((and (
find var *random-special-vars*
)
(setq desc (find var *vars* :key #'var-desc-name)))
(var-desc-type desc))
(t (rcase
...
...
@@ -723,7 +733,7 @@
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
(let* ((var (rcase
(2 (random-from-seq #(v1 v2 v3 v4 v5 v6 v7 v8 v9 v10)))
(2 (random-from-seq
#(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)
))))
(2 (random-from-seq
*random-special-vars*
))))
(e1 (make-random-integer-form s1))
(type (multiple-value-bind (type2 e)
(make-random-type-for-var var e1)
...
...
@@ -745,7 +755,7 @@
(defun make-random-integer-progv-form (size)
(let* ((num-vars (random 4))
(possible-vars
#(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)
)
(possible-vars
*random-special-vars*
)
(vars nil))
(loop repeat num-vars
do (loop for r = (elt possible-vars (random (length possible-vars)))
...
...
@@ -819,12 +829,12 @@
((subtypep '(integer * *) type)
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(rcase
(1 (when (
member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)
)
(1 (when (
find var *random-special-vars*
)
(setq op (random-from-seq #(setf shiftf))
var `(symbol-value ',var))))
(1 (setq op 'multiple-value-setq)
(setq var (list var)))
(5
nil
))
(5
(setf op (random-from-seq #(setq setf shiftf incf decf)))
))
`(,op ,var ,(make-random-integer-form (1- size))))
((and (consp type)
(eq (car type) 'integer)
...
...
@@ -832,7 +842,7 @@
(integerp (third type)))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(rcase
(1 (when (
member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8* *s9*)
)
(1 (when (
find var *random-special-vars*
)
(setq op (random-from-seq #(setf shiftf))
var `(symbol-value ',var))))
(1 (setq op 'multiple-value-setq)
...
...
@@ -918,8 +928,10 @@
(find-package "CL-TEST"))))
(allow-other-keys (and keyarg-p (coin 3)))
)
(destructuring-bind (s1 s2 . opt-sizes)
(random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs)))
(let* ((sizes (random-partition (1- size) (+ 2 keyarg-n (- maxargs minargs))))
(s1 (car sizes))
(s2 (cadr sizes))
(opt-sizes (cddr sizes)))
(let* ((form1
;; Allow return-from of the flet/labels function
(let ((*random-int-form-blocks*
...
...
@@ -1008,11 +1020,11 @@
`(,(random-from-seq '(and or))
,(make-random-pred-form leftsize)
,(make-random-pred-form rightsize))))
(1 (
destructuring-bind (leftsize rightsize
)
(random-partition (1- size) 2
)
`(,(random-from-seq
'(< <= > >= = /= eql equal)
)
,(make-random-integer-form leftsize
)
,
(make-random-integer-form rightsize
))))
(1 (
let* ((nsizes (+ 1 (random 3))
)
(sizes (random-partition (1- size) nsizes))
)
`(,(random-from-seq
(if (= nsizes 2) #(< <= > >= = /= eql equal
)
#(< <= > >= = /=))
)
,
@(mapcar #'make-random-integer-form sizes
))))
(3 (let* ((cond-size (random (max 1 (floor size 2))))
(then-size (random (- size cond-size)))
(else-size (- size 1 cond-size then-size))
...
...
@@ -1020,11 +1032,14 @@
(then-part (make-random-pred-form then-size))
(else-part (make-random-pred-form else-size)))
`(if ,pred ,then-part ,else-part)))
#-poplog
(1 (destructuring-bind (s1 s2)
(random-partition (1- size) 2)
`(ldb-test ,(make-random-byte-spec-form s1)
,(make-random-integer-form s2))))
(2 (let ((form (make-random-integer-form (1- size)))
(op (random-from-seq #(evenp oddp minusp plusp zerop))))
`(,op ,form)))
(2 (destructuring-bind (s1 s2)
(random-partition (1- size) 2)
(let ((arg1 (make-random-integer-form s1))
...
...
@@ -1052,9 +1067,15 @@
(let ((subform (make-random-integer-form (- size 2)))
(type
(rcase
(1 `(real ,@(make-random-integer-range)))
(1 `(rational ,@(make-random-integer-range)))
(1 `(rational ,(+ 1/2 (make-random-integer))))
(1 `(rational * ,(+ 1/2 (make-random-integer))))
(1 `(integer ,@(make-random-integer-range)))
(1 `(integer ,(make-random-integer)))
(1 `(integer * ,(make-random-integer)))
(1 'fixnum)
(1 'bignum)
(1 `(integer)))))
`(typep ,subform ',type)))
)))
...
...
@@ -1128,7 +1149,7 @@
(ecase type
(bit (random 2))
(boolean (random-from-seq #(nil t)))
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| c
l:c
ar)))
(symbol (random-from-seq #(nil t a b c :a :b :c |z| foo |foo| car)))
(unsigned-byte (random-from-interval
(1+ (ash 1 (random *maximum-random-int-bits*))) 0))
(integer (let ((x (ash 1 (random *maximum-random-int-bits*))))
...
...
@@ -1231,8 +1252,8 @@
:kind kind)))))
(let ((unopt-result
(cl
:
handler-case
(cl
:
handler-bind
(cl
-
handler-case
(cl
-
handler-bind
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
(warning #'muffle-warning))
(identity ;; multiple-value-list
...
...
@@ -1243,8 +1264,8 @@
(with-output-to-string
(s) (prin1 c s)))))))
(opt-result
(cl
:
handler-case
(cl
:
handler-bind
(cl
-
handler-case
(cl
-
handler-bind
(#+sbcl (sb-ext::compiler-note #'muffle-warning)
(warning #'muffle-warning))
(identity ;; multiple-value-list
...
...
@@ -1560,16 +1581,33 @@
(try (eval form)))
(prune-fn form try-fn)))
((incf decf)
(try 0)
(assert (member (length form) '(2 3)))
(try (first args))
(try (second args))
(when (second args)
(try `(,op ,(first args))))
(unless (integerp (second args))
(prune (second args)
#'(lambda (form)
(try `(,op ,(first args) ,form))))))
((setq setf shiftf)
(try 0)
;; Assumes only one assignment
(assert (= (length form) 3))
(try (first args))
(try (second args))
(unless (integerp (second args))
(prune (second args)
#'(lambda (form)
(try `(,op ,(first args) ,form))))))
((rotatef)
(try 0)
(mapc try-fn (cdr form)))
((multiple-value-setq)
(try 0)
;; Assumes only one assignment, and one variable
...
...
@@ -1932,6 +1970,14 @@
(prune-list cases
#'(lambda (case try-fn)
(declare (type function try-fn))
(when (and (listp (car case))
(> (length (car case)) 1))
;; try removing constants
(loop for i below (length (car case))
do (funcall try-fn
`((,@(subseq (car case) 0 i)
,@(subseq (car case) (1+ i)))
,@(cdr case)))))
(when (eql (length case) 2)
(prune (cadr case)
#'(lambda (form)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment