Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
ansi-test
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Deploy
Releases
Container Registry
Model registry
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Michał Herda
ansi-test
Commits
8f563608
Commit
8f563608
authored
20 years ago
by
pfdietz
Browse files
Options
Downloads
Patches
Plain Diff
Tweaked the pruner for make-array forms
parent
ab15145b
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
ansi-tests/random-int-form.lsp
+163
-52
163 additions, 52 deletions
ansi-tests/random-int-form.lsp
with
163 additions
and
52 deletions
ansi-tests/random-int-form.lsp
+
163
−
52
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 * *))
((
sub
type
p
'(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
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment