3rdparties/software/cffi_0.21.0/tests/random-tester.lisp (10249 bytes)
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 type) 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 type)) 100 (min (- (type-max rettype) sum) (type-max type))) 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 :pointer)) 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)