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
8f563608
Commit
8f563608
authored
May 24, 2004
by
pfdietz
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Tweaked the pruner for make-array forms
parent
ab15145b
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
163 additions
and
52 deletions
+163
-52
ansi-tests/random-int-form.lsp
ansi-tests/random-int-form.lsp
+163
-52
No files found.
ansi-tests/random-int-form.lsp
View file @
8f563608
...
...
@@ -104,8 +104,8 @@
(defvar *print-immediately* nil)
(defvar *compile-unoptimized-form*
#
-(or gcl clisp armedbear
) t
#
+(or gcl clisp armedbear
) nil)
#
+(or allegro sbcl
) t
#
-(or allegro sbcl
) nil)
(declaim (special *vars*))
...
...
@@ -114,9 +114,13 @@
(type t))
(defun test-random-integer-forms
(size nvars n &key ((:random-state *random-state*) (make-random-state t))
(size nvars n
&key ((:random-state *random-state*) (make-random-state t))
(file-prefix "b")
(index 0))
(index 0)
(random-size nil)
(random-nvars nil)
)
"Generate random integer forms of size SIZE with NVARS variables.
Do this N times, returning all those on which a discrepancy
...
...
@@ -137,7 +141,8 @@
;; #+sbcl (sb-ext::gc :full t)
(prin1 i) (princ " ") (finish-output *standard-output*))
nconc (let ((result (test-random-integer-form
size nvars
(if random-size (1+ (random size)) size)
(if random-nvars (1+ (random nvars)) nvars)
:index (+ index i)
:file-prefix file-prefix)))
(when result
...
...
@@ -147,10 +152,10 @@
result)))
(defun test-random-integer-form
(size nvars &key (index 0) (file-prefix "b")
&aux
(vars (subseq '(a b c d e f g h i j k l m
n o p q r s u v w x y z) 0 nvars)
))
(let* (
(var-ranges (mapcar #'make-random-integer-range vars))
(size nvars &key (index 0) (file-prefix "b")
)
(let* (
(vars (subseq '(a b c d e f g h i j k l m
n o p q r s u v w x y z) 0 nvars
))
(var-ranges (mapcar #'make-random-integer-range vars))
(var-types (mapcar #'(lambda (range)
(let ((lo (car range))
(hi (cadr range)))
...
...
@@ -249,6 +254,14 @@
(let ((r (ash 1 (1+ (random 32)))))
(- (random r) (floor (/ r 2)))))
(defun random-var-desc ()
(loop
(let* ((pos (random (length *vars*)))
(desc (elt *vars* pos)))
(when (= pos (position (var-desc-name desc) (the list *vars*)
:key #'var-desc-name))
(return desc)))))
(defun make-random-integer-form (size)
"Generate a random legal lisp form of size SIZE (roughly)."
...
...
@@ -258,7 +271,17 @@
when
(rcase
(10 (make-random-integer))
(9 (if *vars* (var-desc-name (random-from-seq *vars*))
(9 (if *vars*
(let* ((desc (random-var-desc))
(type (var-desc-type desc))
(name (var-desc-name desc)))
(cond
((subtypep type 'integer) name)
((subtypep type '(array integer nil)) `(aref ,name))
((subtypep type '(cons integer integer))
(rcase (1 `(car ,name))
(1 `(cdr ,name))))
(t nil)))
nil))
(1 (if *go-tags* `(go ,(random-from-seq *go-tags*)) nil))
(2 (if *flet-names*
...
...
@@ -588,15 +611,35 @@
`(eval (values ,@args))))
)))
(defun make-random-type-for-var (var e1)
(let (desc)
(values
(cond
((and (member var '(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*) :test #'eq)
(setq desc (find var *vars* :key #'var-desc-name)))
(var-desc-type desc))
(t (rcase
(4 '(integer * *))
(2 (setq e1 `(make-array nil :initial-element ,e1
,@(rcase (1 nil) (1 '(:adjustable t)))))
'(array integer nil))
(1 (setq e1 `(cons ,e1 ,(make-random-integer-form 1)))
'(cons integer integer))
(1 (setq e1 `(cons ,(make-random-integer-form 1) ,e1))
'(cons integer integer)))))
e1)))
(defun make-random-integer-binding-form (size)
(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 #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*)))))
(e1 (make-random-integer-form s1))
(e2 (let ((*vars* (cons (make-var-desc :name var
:type '(integer * *))
(type (multiple-value-bind (type2 e)
(make-random-type-for-var var e1)
(setq e1 e)
type2))
(e2 (let ((*vars* (cons (make-var-desc :name var :type type)
*vars*)))
(make-random-integer-form s2)))
(op (random-from-seq #(let let*))))
...
...
@@ -604,18 +647,24 @@
(if (member var *vars* :key #'var-desc-name)
(make-random-integer-form size)
(rcase
(8 `(,op ((,var ,e1)) ,e2))
(8 `(,op ((,var ,e1))
,@(rcase (1 `((declare (dynamic-extent ,var))))
(1 nil))
,e2))
(2 `(multiple-value-bind (,var) ,e1 ,e2)))))))
(defun make-random-integer-progv-form (size)
(let* ((num-vars (random 4))
(possible-vars #(*s1* *s2* *s3* *s4*
*s5* *s6* *s7* *s8*))
(possible-vars #(*s1* *s2* *s3* *s4* *s5* *s6* *s7* *s8*))
(vars nil))
(loop repeat num-vars
do (loop for r = (elt possible-vars (random (length possible-vars)))
while (member r vars)
finally (push r vars)))
(setq vars (remove-if #'(lambda (var) (let ((desc (find var *vars* :key #'var-desc-name)))
(and desc (not (subtypep (var-desc-type desc) 'integer)))))
vars)
num-vars (length vars))
(if (null vars)
`(progv nil nil ,(make-random-integer-form (1- size)))
(destructuring-bind (s1 s2) (random-partition (1- size) 2)
...
...
@@ -676,20 +725,27 @@
(var (var-desc-name vdesc))
(type (var-desc-type vdesc))
(op (random-from-seq #(setq setf #-(or armedbear)shiftf))))
(rcase
(3 nil)
(1 (setq op 'multiple-value-setq)
(setq var (list var))))
(cond
((
equal type '(integer * *)
)
((
subtypep '(integer * *) type
)
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(when (coin 4)
(setq op 'multiple-value-setq)
(setq var (list var)))
`(,op ,var ,(make-random-integer-form (1- size))))
((and (consp type)
(eq (car type) 'integer)
(integerp (second type))
(integerp (third type)))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(when (coin 4)
(setq op 'multiple-value-setq)
(setq var (list var)))
`(,op ,var ,(random-from-interval (1+ (third type)) (second type))))
((and (subtypep '(array integer nil) type))
(assert (not (member var '(lv1 lv2 lv3 lv4 lv5 lv6 lv7 lv8))))
(when (eq op 'setq)
(setq op (random-from-seq #(setf shiftf))))
`(,op (aref ,var) ,(make-random-integer-form (- size 2))))
;; Abort -- can't assign
(t (make-random-integer-form size))))
(make-random-integer-form size)))
...
...
@@ -735,20 +791,27 @@
(rcase
(1 minargs)
(1 (+ minargs (random 4)))))
(keyarg-p (coin 2))
(keyarg-n (if keyarg-p (random 3) 0))
(arg-names (loop for i from 1 to maxargs
collect (fn-arg-name fname i))))
collect (fn-arg-name fname i)))
(key-arg-names (loop for i from 1 to keyarg-n
collect (intern (format nil "KEY~A" i)
(find-package "CL-TEST"))))
(allow-other-keys (and keyarg-p (coin 3)))
)
(destructuring-bind (s1 s2 . opt-sizes)
(random-partition (1- size) (+ 2 (- maxargs minargs)))
(random-partition (1- size) (+ 2
keyarg-n
(- maxargs minargs)))
(let* ((form1
;; Allow return-from of the flet/labels function
(let ((*random-int-form-blocks*
(cons fname *random-int-form-blocks*))
(*vars* (nconc (loop for var in
arg-names
(*vars* (nconc (loop for var in
(append arg-names key-arg-names)
collect (make-var-desc :name var
:type '(integer * *)))
*vars*)))
(make-random-integer-form s1)))
(form2 (let ((*flet-names* (cons (list fname minargs maxargs)
(form2 (let ((*flet-names* (cons (list fname minargs maxargs
keyarg-p
)
*flet-names*)))
(make-random-integer-form s2)))
(opt-forms (mapcar #'make-random-integer-form opt-sizes)))
...
...
@@ -757,10 +820,26 @@
&optional
,@(mapcar #'list
(subseq arg-names minargs)
opt-forms))
opt-forms)
,@(when keyarg-p
(append '(&key)
(mapcar #'list
key-arg-names
(subseq opt-forms (- maxargs minargs)))
(when allow-other-keys '(&allow-other-keys))
)))
,form1))
,form2)
`(,op ((,fname ,arg-names ,form1)) ,form2))))))))
`(,op ((,fname (,@arg-names
,@(when keyarg-p
(append '(&key)
(mapcar #'list
key-arg-names
opt-forms )
(when allow-other-keys '(&allow-other-keys))
)))
,form1))
,form2))))))))
(defun make-random-tagbody (size)
(let* ((num-forms (random 6))
...
...
@@ -1127,6 +1206,16 @@
(mapc try-fn args)
(prune-fn form try-fn))
((make-array)
(when (and (eq (car args) nil)
(eq (cadr args) ':initial-element)
; (null (cdddr args))
)
(prune (caddr args) #'(lambda (form) (try `(make-array nil :initial-element ,form . ,(cdddr args)))))))
((cons)
(prune-fn form try-fn))
((dotimes)
(try 0)
(let* ((binding-form (first args))
...
...
@@ -1287,20 +1376,24 @@
((bit sbit elt aref svref)
(try 0)
(assert (= (length args) 2))
(let ((arg1 (car args))
(arg2 (cadr args)))
(when (and (consp arg2)
(eql (car arg2) 'min)
(integerp (cadr arg2)))
(let ((arg2.2 (caddr arg2)))
(when (and (consp arg2.2)
(eql (car arg2.2) 'max)
(integerp (cadr arg2.2)))
(prune (caddr arg2.2)
#'(lambda (form)
(try `(,op ,arg1 (min ,(cadr arg2)
(max ,(cadr arg2.2) ,form)))))))))))
(when (= (length args) 2)
(let ((arg1 (car args))
(arg2 (cadr args)))
(when (and (consp arg2)
(eql (car arg2) 'min)
(integerp (cadr arg2)))
(let ((arg2.2 (caddr arg2)))
(when (and (consp arg2.2)
(eql (car arg2.2) 'max)
(integerp (cadr arg2.2)))
(prune (caddr arg2.2)
#'(lambda (form)
(try `(,op ,arg1 (min ,(cadr arg2)
(max ,(cadr arg2.2) ,form))))))))))))
((car cdr)
(try 0)
(try 1))
((if)
(let (;; (pred (first args))
...
...
@@ -1778,14 +1871,20 @@
(binding-list (cadr form))
(body (cddr form))
;; (body-len (length body))
(len (length binding-list)))
;; (len (length binding-list))
)
;; Try to simplify (let ((<name> <form>)) ...) to <form>
#|
(when (and (>= len 1)
;; (eql body-len 1)
;; (eql (caar binding-list) (car body))
)
(funcall try-fn (cadar binding-list)))
(let ((val-form (cadar binding-list)))
(unless (and (consp val-form)
(eql (car val-form) 'make-array))
(funcall try-fn val-form))))
|#
;; Try to simplify the forms in the RHS of the bindings
(prune-list binding-list
...
...
@@ -1809,10 +1908,14 @@
(let ((binding (first binding-list)))
(unless (or (consp (second binding))
(has-binding-to-var (first binding) body)
(has-assignment-to-var (first binding) body))
(has-assignment-to-var (first binding) body)
)
(funcall try-fn `(let ()
,@(subst (second binding)
(first binding) body))))))
(first binding)
(remove-if #'(lambda (x) (and (consp x) (eq (car x) 'declare)))
body)
))))))
(prune (car (last body))
#'(lambda (form2)
(funcall try-fn
...
...
@@ -1862,6 +1965,12 @@
(binding-list (cadr form))
(body (cddr form)))
;; Remove a declaration, if any
(when (and (consp body)
(consp (car body))
(eq (caar body) 'declare))
(funcall try-fn `(,op ,binding-list ,@(cdr body))))
;; Try to prune optional arguments
(prune-list binding-list
#'(lambda (binding try-fn)
...
...
@@ -1869,7 +1978,8 @@
(let* ((name (car binding))
(args (cadr binding))
(body (cddr binding))
(opt-pos (position '&optional (the list args))))
(opt-pos (position-if #'(lambda (e) (member e '(&key &optional)))
(the list args))))
(when opt-pos
(incf opt-pos)
(let ((normal-args (subseq args 0 (1- opt-pos)))
...
...
@@ -1877,11 +1987,12 @@
(prune-list optionals
#'(lambda (opt-lambda-arg try-fn)
(declare (type function try-fn))
(let ((name (first opt-lambda-arg))
(form (second opt-lambda-arg)))
(prune form
#'(lambda (form)
(funcall try-fn (list name form))))))
(when (consp opt-lambda-arg)
(let ((name (first opt-lambda-arg))
(form (second opt-lambda-arg)))
(prune form
#'(lambda (form)
(funcall try-fn (list name form)))))))
#'(lambda (opt-args)
(funcall try-fn
`(,name (,@normal-args
...
...
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