GopherProxy

	trandom-tester.lisp - clic - Clic is an command line interactive client for gop…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	trandom-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)