random-tester.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
 (HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
 (DIR) Log
 (DIR) Files
 (DIR) Refs
 (DIR) Tags
 (DIR) README
 (DIR) 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 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)