What's new in "tests/random-tester.lisp": { hunk ./tests/random-tester.lisp 35 ;;; but obviously as soon as you do the maths that it's not quite ;;; feasable for more that 4 or 5 arguments. ;;; -;;; TODO: actually run random tests, ie compile/load/run the tests -;;; this code can generate. +;;; The main external function is `run-random-numeric-tests', which +;;; generates executes, and removes a randomized test suite. See its +;;; docstring for more. (defpackage #:cffi-random-tester hunk ./tests/random-tester.lisp 40 - (:use #:cl #:cffi #:regression-test)) + (:use #:cl #:cffi #:regression-test) + (:export #:run-random-numeric-tests)) (in-package #:cffi-random-tester) hunk ./tests/random-tester.lisp 43 + +(eval-when (:compile-toplevel :load-toplevel :execute) + (assert (find-package "ASDF") () + "ASDF must be loaded for me to work; see `make-target-maker'")) + +(defvar *test-package*) +(setf (documentation '*test-package* 'variable) + "The package in which generated tests are compiled and stored. +The extra package allows us to do a good portion of cleanup on +the system after testing by simply deleting the package.") + +(defparameter *random-test-file-prefix* "tr" + "Prefix to use in generating randomly-named files.") (defstruct (c-type (:conc-name type-)) keyword hunk ./tests/random-tester.lisp 102 (defun n-random-types (n) (loop repeat n collect (nth (random (length +types+)) +types+))) +(assert (equal '(:long-long :unsigned-long-long) + (mapcar #'type-keyword (last +types+ 2))) + (+types+) + "`n-random-types-no-ll' and `compute-test-type-set'~ + probably won't work anymore") ;;; same as above, without the long long types (defun n-random-types-no-ll (n) (loop repeat n collect (nth (random (- (length +types+) 2)) +types+))) hunk ./tests/random-tester.lisp 123 (min (- (type-max rettype) sum) (type-max type))) do (incf sum x) collect x)) - -(defun combinations (n items) - (let ((combs '())) - (labels ((rec (n accum) - (if (= n 0) - (push accum combs) - (loop for item in items - do (rec (1- n) (cons item accum)))))) - (rec n '()) - combs))) (defun function-name (rettype arg-types) (format nil "sum_~A_~{_~A~}" hunk ./tests/random-tester.lisp 129 (type-abbrev rettype) (mapcar #'type-abbrev arg-types))) -(defun c-function (rettype arg-types) +(defun c-function (rettype arg-types &optional (stream t)) (let ((args (loop for type in arg-types and i from 1 collect (list (type-name type) (format nil "a~A" i))))) hunk ./tests/random-tester.lisp 132 - (format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~ + (format stream "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~ { return ~A(~A) ~{~A~^ + ~}~A; }" (type-name rettype) (function-name rettype arg-types) args (if (eq (type-keyword rettype) :pointer) hunk ./tests/random-tester.lisp 155 ""))) (if (eq (type-keyword rettype) :pointer) "))" "")))) -(defun c-callback (rettype arg-types args) - (format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~ +(defun c-callback (rettype arg-types args &optional (stream t)) + (format stream "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~ { return func(~{~A~^, ~}); }" (type-name rettype) (function-name rettype arg-types) (type-name rettype) (mapcar #'type-name arg-types) hunk ./tests/random-tester.lisp 176 (format t "/* ~A args */" (1- n)) (loop for comb in (combinations n +types+) do (terpri) (c-function (car comb) (cdr comb)) - (terpri) (c-callback (car comb) (cdr comb))))))) + (terpri) (error "TODO: 3rd arg?") + #|(c-callback (car comb) (cdr comb))|#))))) (defmacro with-conversion (type form) (case type hunk ./tests/random-tester.lisp 202 (:float (float n)) (:pointer `(make-pointer ,n)) (t n)))))) + +(defun may-be-gentestname-p (symbol) + "Answer whether SYMBOL *may* be one generated by me. In other +terms, (satisfies GENTESTNAME-P), were such a type to be valid, +is a subtype of (satisfies MAY-BE-GENTESTNAME-P)." + (and (if (boundp '*test-package*) + (eq *test-package* (symbol-package symbol)) + ;; lazy coding based on `run-random-numeric-tests' + (string= #0='"CFFI-RANDOM-TESTER-" + (package-name (symbol-package symbol)) + :end2 (length #0#))) + ;; lazy coding based on the definitions of `gen-function-test' + ;; and `gen-callback-test' below + (or (string= "DEFCFUN." symbol :end2 8) + (string= "CALLBACKS." symbol :end2 10)))) (defun gen-function-test (rettype arg-types) (let* ((fun-name (function-name rettype arg-types)) hunk ./tests/random-tester.lisp 264 (sum (reduce #'+ args))) (c-callback rettype arg-types args) (gen-callback-test rettype arg-types sum))) +[_^L_] +;;;; Temporary file generation + +(defparameter *test-pathname-defaults* + (make-pathname :defaults *load-truename* + :name nil :type nil :version :newest) + "Pathname used to supply directory and other information to +temporary files.") + +(defun call-with-temp-file (name-prefix procedure &rest directory-args) + "Create a temporary file named by postfixing NAME-PREFIX with +something random, of TYPE, generating the pathname with +additional DIRECTORY-ARGS. Call PROCEDURE with an open output +stream on the temporary file. Afterwards, close the stream +unconditionally, even if exited non-locally, as with +`with-open-file'. Answer the result of calling PROCEDURE. + +Unless PROCEDURE signals a `serious-condition' at any time that +is not handled within PROCEDURE, delete the file upon exit using +`unwind-protect'." + (let (file filename (delete-flag t)) + (loop do (setf filename (apply #'make-pathname :name + (format nil "~A~36,5,'0R" ;5 random alnums + name-prefix + (random #36r100000)) + directory-args)) + until (setf file (open filename :direction :output :if-exists nil))) + (unwind-protect + (multiple-value-prog1 + (handler-bind ((serious-condition (lambda (c) + (declare (ignore c)) + (setf delete-flag nil)))) + (funcall procedure file)) + (close (shiftf file nil))) + (and file (open-stream-p file) (close file :abort t)) + (when delete-flag (handler-case (delete-file filename) + (file-error () nil)))))) + +(defun call-with-c-test-file (procedure) + (call-with-temp-file (concatenate 'string *random-test-file-prefix* "c") + procedure :type "c" + :defaults *test-pathname-defaults*)) + +(defun call-with-lisp-test-file (procedure) + (call-with-temp-file (concatenate 'string *random-test-file-prefix* "l") + procedure :type "lisp" + :defaults *test-pathname-defaults*)) + +(defun make-target-maker (mk-filename &optional mk-stream) + "Answer a one-arg procedure that will run make on makefile +MK-FILENAME (with MK-STREAM open for writing, if provided) in the +test directory, using TARGET-NAME as its target." + (let ((makefile-basename + (make-pathname :directory nil :defaults mk-filename))) + (lambda (target-name) + (when mk-stream (force-output mk-stream)) + ;; copied from ../cffi-tests.asd + (asdf:run-shell-command + #-freebsd "cd ~A; make -f ~A ~A" + #+freebsd "cd ~A; gmake -f ~A ~A" + (namestring *test-pathname-defaults*) + (namestring makefile-basename) + target-name)))) + +(defun write-file-contents (input-file output-stream) + (with-open-file (orig-file input-file) + (let ((seq (make-string #0=8000))) + (loop for length-read = (read-sequence seq orig-file) + do (write-string seq output-stream :end length-read) + until (< length-read #0#))))) + +;;; I copy the Makefile in the tests directory because I (s11) am +;;; really terrible at cross-platform things, there seems to be +;;; sufficient XP code in Makefile for my build purposes, and I would +;;; rather not think about it any more than that. + +(defun call-with-makefile (procedure) + "Create a temporary Makefile (copying Makefile in the tests +directory), passing two arguments to PROCEDURE: an output stream +on the makefile, and a one-arg procedure that, when called, will +invoke the given target in the makefile. Answer the result of +calling PROCEDURE." + (call-with-temp-file + (concatenate 'string *random-test-file-prefix* "mk") + (lambda (mk-stream) + (write-file-contents + (make-pathname :name "Makefile" :type nil + :defaults *test-pathname-defaults*) + mk-stream) + (funcall procedure mk-stream (make-target-maker (pathname mk-stream)))) + :type nil :defaults *test-pathname-defaults*)) +[_^L_] +;;;; Random test selection + +;;; The possible tests grow exponentially with the number of args. To +;;; see this in code, see `combination-count'. Therefore, we have to +;;; choose our types carefully. Fortunately, `combination-ref' makes +;;; this task much easier. + +(defun combinations (n items) + (let ((combs '())) + (labels ((rec (n accum) + (if (= n 0) + (push accum combs) + (loop for item in items + do (rec (1- n) (cons item accum)))))) + (rec n '()) + combs))) + +(defun combination-count (n items) + "Answer (length (combinations N ITEMS)) without computing them." + (expt (length items) n)) + +(defun combination-ref (n items x) + "Answer the Xth-computed N-tuple combination of ITEMS." + (if (zerop n) + '() + (multiple-value-bind (quotient mod) (truncate x (length items)) + (cons (nth mod items) (combination-ref (1- n) items quotient))))) + +(defun compute-test-type-set (item-count argcount) + "Answer a list of ITEM-COUNT unique test type signatures. Each +signature looks like (rettype argtype ...), where there are +ARGCOUNT argtypes. If ITEM-COUNT >= the number of possible +signatures for ARGCOUNT args, answer the complete set of +combinations." + (incf argcount) ;treat RETTYPE uniformly + (let* ((available-types + (if (member 'cffi-features:no-long-long *features*) + (remove-if (lambda (k) + (member k '(:long-long :unsigned-long-long))) + +types+ :key #'type-keyword) + +types+)) + (max-signatures (combination-count argcount available-types))) + (if (>= item-count max-signatures) + (combinations argcount available-types) + ;; There are other special cases that could be done when e.g. + ;; (>= item-count (* 60/100 max-signatures)). Unless they + ;; become an issue, I won't worry about them. + (let ((signatures (make-hash-table :test 'eql :size item-count))) + (labels ((next-sig (sig-num) + ;; Compute a random combination with linear clash + ;; resolution. + (if (nth-value 1 (gethash sig-num signatures)) + (next-sig (rem (1+ sig-num) max-signatures)) + (setf (gethash sig-num signatures) t)))) + (loop repeat item-count + do (next-sig (random max-signatures)))) + (loop for sig-num being each hash-key in signatures + collect (combination-ref argcount available-types sig-num)))))) +[_^L_] +;;;; Test driver and result handling + +(defun failed-tests-after-testing () + "Answer the tests that failed. Only makes sense to call this +after testing." + (set-difference (remove-if-not #'may-be-gentestname-p + (regression-test:pending-tests)) + regression-test::*expected-failures*)) + +(defun write-test-pair (type-signature c-stream lisp-stream) + "Write the needed C and Lisp forms to test callout and callback +for TYPE-SIGNATURE, a list of types, on C-STREAM and LISP-STREAM, +respectively." + (destructuring-bind (rettype &rest argtypes) type-signature + (with-standard-io-syntax + (let ((*package* *test-package*)) + (format c-stream "/* Tests for typesig ~A (~{~A~^, ~}) */~%~%" + (type-name rettype) (mapcar #'type-name argtypes)) + (format lisp-stream ";;;; Tests for typesig ~S ~S~%~%" + (type-keyword rettype) (mapcar #'type-keyword argtypes)) + (c-function rettype argtypes c-stream) + (write (gen-function-test rettype argtypes) + :stream lisp-stream :pretty t :circle t) + (fresh-line c-stream) + (fresh-line lisp-stream) + (let* ((callback-values (random-sum rettype argtypes))) + (c-callback rettype argtypes callback-values c-stream) + (write (gen-callback-test rettype argtypes + (reduce #'+ callback-values)) + :stream lisp-stream :pretty t :circle t)) + (loop repeat 2 do (terpri c-stream) (terpri lisp-stream))))) + (values)) + +(defun run-random-numeric-tests (&optional (each-test-count 250) + (min-argcount 1) (max-argcount 4)) + "Generate a Makefile, C source file, and Lisp source file in +the CFFI test directory `*test-pathname-defaults*', execute the +generated test suite, and clean up RT and the image as much as +reasonable. If there are test failures, keep the generated files +and print some (TODO: what?) information on `*error-output*'. +Answer something useful (TODO)." + (let* ((*test-package* + (make-package + (format nil "CFFI-RANDOM-TESTER-~A" + (shiftf *gensym-counter* (1+ *gensym-counter*))) + :use '())) + ;; for `cffi-utils:symbolicate' and Lisp writing + (*package* *test-package*)) + (unwind-protect + (call-with-c-test-file + (lambda (c-stream) + ;; etc.TODO + (call-with-lisp-test-file + (lambda (lisp-stream) + (call-with-makefile + (lambda (makefile-stream make-target-proc) + #|TODO|#)))))) + (loop for sym being the present-symbols of *test-package* + when (may-be-gentestname-p sym) + do (regression-test:rem-test sym)) + (delete-package *test-package*)))) + +;; Notes: rt:*do-tests-when-defined* must be NIL while +;; compiling/loading the Lisp tempfile. ;; (defmacro define-function-and-callback-tests (min max) ;; `(progn hunk ./tests/random-tester.lisp 488 ;; collect (gen-callback-test (car comb) (cdr comb)))))) ;; (define-function-and-callback-tests 3 5) + }