random-tester.lisp - clic - Clic is an command line interactive client for goph… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
LICENSE | |
--- | |
random-tester.lisp (10249B) | |
--- | |
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- | |
2 ;;; | |
3 ;;; random-tester.lisp --- Random test generator. | |
4 ;;; | |
5 ;;; Copyright (C) 2006, Luis Oliveira <loliveira(@)common-lisp.net> | |
6 ;;; | |
7 ;;; Permission is hereby granted, free of charge, to any person | |
8 ;;; obtaining a copy of this software and associated documentation | |
9 ;;; files (the "Software"), to deal in the Software without | |
10 ;;; restriction, including without limitation the rights to use, copy, | |
11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies | |
12 ;;; of the Software, and to permit persons to whom the Software is | |
13 ;;; furnished to do so, subject to the following conditions: | |
14 ;;; | |
15 ;;; The above copyright notice and this permission notice shall be | |
16 ;;; included in all copies or substantial portions of the Software. | |
17 ;;; | |
18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND | |
21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT | |
22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, | |
23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, | |
24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER | |
25 ;;; DEALINGS IN THE SOFTWARE. | |
26 ;;; | |
27 | |
28 ;;; This code was used to generate the C and Lisp source code for | |
29 ;;; the CALLBACKS.BFF.[12] and DEFCFUN.BFF.[12] tests. | |
30 ;;; | |
31 ;;; The original idea was to test all combinations of argument types | |
32 ;;; but obviously as soon as you do the maths that it's not quite | |
33 ;;; feasable for more that 4 or 5 arguments. | |
34 ;;; | |
35 ;;; TODO: actually run random tests, ie compile/load/run the tests | |
36 ;;; this code can generate. | |
37 | |
38 (defpackage #:cffi-random-tester | |
39 (:use #:cl #:cffi #:alexandria #:regression-test)) | |
40 (in-package #:cffi-random-tester) | |
41 | |
42 (defstruct (c-type (:conc-name type-)) | |
43 keyword | |
44 name | |
45 abbrev | |
46 min | |
47 max) | |
48 | |
49 (defparameter +types+ | |
50 (mapcar (lambda (type) | |
51 (let ((keyword (first type)) | |
52 (name (second type))) | |
53 (multiple-value-bind (min max) | |
54 ;; assume we can represent an integer in the range | |
55 ;; [-2^16 2^16-1] in a float/double without causing | |
56 ;; rounding errors (probably a lame assumption) | |
57 (let ((type-size (if (or (eq keyword :float) | |
58 (eq keyword :double)) | |
59 16 | |
60 (* 8 (foreign-type-size keyword))… | |
61 (if (or (eql (char name 0) #\u) (eq keyword :pointer… | |
62 (values 0 (1- (expt 2 type-size))) | |
63 (values (- (expt 2 (1- type-size))) | |
64 (1- (expt 2 (1- type-size)))))) | |
65 (make-c-type :keyword keyword :name name :abbrev (third … | |
66 :min min :max max)))) | |
67 '((:char "char" "c") | |
68 (:unsigned-char "unsigned char" "uc") | |
69 (:short "short" "s") | |
70 (:unsigned-short "unsigned short" "us") | |
71 (:int "int" "i") | |
72 (:unsigned-int "unsigned int" "ui") | |
73 (:long "long" "l") | |
74 (:unsigned-long "unsigned long" "ul") | |
75 (:float "float" "f") | |
76 (:double "double" "d") | |
77 (:pointer "void*" "p") | |
78 (:long-long "long long" "ll") | |
79 (:unsigned-long-long "unsigned long long" "ull")))) | |
80 | |
81 (defun find-type (keyword) | |
82 (find keyword +types+ :key #'type-keyword)) | |
83 | |
84 (defun n-random-types (n) | |
85 (loop repeat n collect (nth (random (length +types+)) +types+))) | |
86 | |
87 ;;; same as above, without the long long types | |
88 (defun n-random-types-no-ll (n) | |
89 (loop repeat n collect (nth (random (- (length +types+) 2)) +types+))) | |
90 | |
91 (defun random-range (x y) | |
92 (+ x (random (+ (- y x) 2)))) | |
93 | |
94 (defun random-sum (rettype arg-types) | |
95 "Returns a list of integers that fit in the respective types in the | |
96 ARG-TYPES list and whose sum fits in RETTYPE." | |
97 (loop with sum = 0 | |
98 for type in arg-types | |
99 for x = (random-range (max (- (type-min rettype) sum) (type-min … | |
100 (min (- (type-max rettype) sum) (type-max … | |
101 do (incf sum x) | |
102 collect x)) | |
103 | |
104 (defun combinations (n items) | |
105 (let ((combs '())) | |
106 (labels ((rec (n accum) | |
107 (if (= n 0) | |
108 (push accum combs) | |
109 (loop for item in items | |
110 do (rec (1- n) (cons item accum)))))) | |
111 (rec n '()) | |
112 combs))) | |
113 | |
114 (defun function-name (rettype arg-types) | |
115 (format nil "sum_~A_~{_~A~}" | |
116 (type-abbrev rettype) | |
117 (mapcar #'type-abbrev arg-types))) | |
118 | |
119 (defun c-function (rettype arg-types) | |
120 (let ((args (loop for type in arg-types and i from 1 | |
121 collect (list (type-name type) (format nil "a~A" i))… | |
122 (format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~ | |
123 { return ~A(~A) ~{~A~^ + ~}~A; }" | |
124 (type-name rettype) (function-name rettype arg-types) args | |
125 (if (eq (type-keyword rettype) :pointer) | |
126 "(void *)((unsigned int)(" | |
127 "") | |
128 (type-name rettype) | |
129 (loop for arg-pair in args collect | |
130 (format nil "~A~A~A" | |
131 (cond ((string= (first arg-pair) "void*") | |
132 "(unsigned int) ") | |
133 ((or (string= (first arg-pair) "double") | |
134 (string= (first arg-pair) "float")) | |
135 "((int) ") | |
136 (t "")) | |
137 (second arg-pair) | |
138 (if (member (first arg-pair) | |
139 '("void*" "double" "float") | |
140 :test #'string=) | |
141 ")" | |
142 ""))) | |
143 (if (eq (type-keyword rettype) :pointer) "))" "")))) | |
144 | |
145 (defun c-callback (rettype arg-types args) | |
146 (format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~ | |
147 { return func(~{~A~^, ~}); }" | |
148 (type-name rettype) (function-name rettype arg-types) | |
149 (type-name rettype) (mapcar #'type-name arg-types) | |
150 (loop for type in arg-types and value in args collect | |
151 (format nil "~A~A" | |
152 (if (eq (type-keyword type) :pointer) | |
153 "(void *) " | |
154 "") | |
155 value)))) | |
156 | |
157 ;;; (output-c-code #p"generated.c" 3 5) | |
158 (defun output-c-code (file min max) | |
159 (with-open-file (stream file :direction :output :if-exists :error) | |
160 (let ((*standard-output* stream)) | |
161 (format t "/* automatically generated functions and callbacks */~%… | |
162 (loop for n from min upto max do | |
163 (format t "/* ~A args */" (1- n)) | |
164 (loop for comb in (combinations n +types+) do | |
165 (terpri) (c-function (car comb) (cdr comb)) | |
166 (terpri) (c-callback (car comb) (cdr comb))))))) | |
167 | |
168 (defmacro with-conversion (type form) | |
169 (case type | |
170 (:double `(float ,form 1.0d0)) | |
171 (:float `(float ,form)) | |
172 (:pointer `(make-pointer ,form)) | |
173 (t form))) | |
174 | |
175 (defun integer-conversion (type form) | |
176 (case type | |
177 ((:double :float) `(values (floor ,form))) | |
178 (:pointer `(pointer-address ,form)) | |
179 (t form))) | |
180 | |
181 (defun gen-arg-values (rettype arg-types) | |
182 (let ((numbers (random-sum rettype arg-types))) | |
183 (values | |
184 (reduce #'+ numbers) | |
185 (loop for type in arg-types and n in numbers | |
186 collect (case (type-keyword type) | |
187 (:double (float n 1.0d0)) | |
188 (:float (float n)) | |
189 (:pointer `(make-pointer ,n)) | |
190 (t n)))))) | |
191 | |
192 (defun gen-function-test (rettype arg-types) | |
193 (let* ((fun-name (function-name rettype arg-types)) | |
194 (fun-sym (cffi::lisp-function-name fun-name))) | |
195 (multiple-value-bind (sum value-forms) | |
196 (gen-arg-values rettype arg-types) | |
197 `(progn | |
198 (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) | |
199 ,@(loop for type in arg-types and i from 1 collect | |
200 (list (symbolicate '#:a (format nil "~A" i)) | |
201 (type-keyword type)))) | |
202 (deftest ,(symbolicate '#:defcfun. fun-sym) | |
203 ,(integer-conversion (type-keyword rettype) | |
204 `(,fun-sym ,@value-forms)) | |
205 ,sum))))) | |
206 | |
207 (defun gen-callback-test (rettype arg-types sum) | |
208 (let* ((fname (function-name rettype arg-types)) | |
209 (cb-sym (cffi::lisp-function-name fname)) | |
210 (fun-name (concatenate 'string "call_" fname)) | |
211 (fun-sym (cffi::lisp-function-name fun-name)) | |
212 (arg-names (loop for i from 1 upto (length arg-types) collect | |
213 (symbolicate '#:a (format nil "~A" i))))) | |
214 `(progn | |
215 (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointe… | |
216 (defcallback ,cb-sym ,(type-keyword rettype) | |
217 ,(loop for type in arg-types and name in arg-names | |
218 collect (list name (type-keyword type))) | |
219 ,(integer-conversion | |
220 (type-keyword rettype) | |
221 `(+ ,@(mapcar (lambda (tp n) | |
222 (integer-conversion (type-keyword tp) n)) | |
223 arg-types arg-names)))) | |
224 (deftest ,(symbolicate '#:callbacks. cb-sym) | |
225 ,(integer-conversion (type-keyword rettype) | |
226 `(,fun-sym (callback ,cb-sym))) | |
227 ,sum)))) | |
228 | |
229 (defun cb-test (&key no-long-long) | |
230 (let* ((rettype (find-type (if no-long-long :long :long-long))) | |
231 (arg-types (if no-long-long | |
232 (n-random-types-no-ll 127) | |
233 (n-random-types 127))) | |
234 (args (random-sum rettype arg-types)) | |
235 (sum (reduce #'+ args))) | |
236 (c-callback rettype arg-types args) | |
237 (gen-callback-test rettype arg-types sum))) | |
238 | |
239 ;; (defmacro define-function-and-callback-tests (min max) | |
240 ;; `(progn | |
241 ;; ,@(loop for n from min upto max appending | |
242 ;; (loop for comb in (combinations n +types+) | |
243 ;; collect (gen-function-test (car comb) (cdr comb)) | |
244 ;; collect (gen-callback-test (car comb) (cdr comb)))… | |
245 | |
246 ;; (define-function-and-callback-tests 3 5) |