New patches: [A random numeric test generator (except outermost driver code) Stephen Compall **20060828031634 * Everything on pages "Temporary file generation" and "Test driver and result handling", and most of "Random test selection" is new. * Add a "stream" argument to C-FUNCTION and C-CALLBACK. * `output-c-code' is broken, and I don't know whether it's useful, so snap it in half more permanently. ] < > { 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))) + +;;;; 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*)) + +;;;; 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)))))) + +;;;; 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) + } [Make working driver for run-random-numeric-tests Stephen Compall **20060831093408 * Rename `combinations' to `permutations', because that's what they really are. * `gen-function-test' and `gen-callback-test' now answer the RT test name (a symbol) as their second values. * *test-c-header* and *library-symbol-name*: new variables. * random-range: Off-by-one error. * c-function: missing open paren for void*->unsigned-int cast. * may-be-gentestname-p didn't really work as was, so now using new helper string-starts-with-p. * Rename write-test-pair to prepare-test-pair, and split it up. It also answers its RT test names. * Bleeding useful new helper `shlib-target-name'. * prepare-make-target, write-*-preamble: New functions. ] < > { hunk ./tests/random-tester.lisp 57 (defparameter *random-test-file-prefix* "tr" "Prefix to use in generating randomly-named files.") +(defparameter *test-c-header* "test-preamble.h" + "Name of the header file to include in the C test file.") + +(defparameter *library-symbol-name* "RANDTEST" + "Name of the symbol to intern into `*test-package*' and use as +the name of the library for `define-foreign-library'.") + (defstruct (c-type (:conc-name type-)) keyword name hunk ./tests/random-tester.lisp 112 (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") + "`n-random-types-no-ll' 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 118 (defun random-range (x y) - (+ x (random (+ (- y x) 2)))) + "Answer a `random' between X and Y, inclusive." + (+ x (random (1+ (- y x))))) (defun random-sum (rettype arg-types) "Returns a list of integers that fit in the respective types in the hunk ./tests/random-tester.lisp 149 (loop for arg-pair in args collect (format nil "~A~A~A" (cond ((string= (first arg-pair) "void*") - "(unsigned int) ") + "((unsigned int) ") ((or (string= (first arg-pair) "double") (string= (first arg-pair) "float")) "((int) ") hunk ./tests/random-tester.lisp 181 (format t "/* automatically generated functions and callbacks */~%~%") (loop for n from min upto max do (format t "/* ~A args */" (1- n)) - (loop for comb in (combinations n +types+) do + (loop for comb in (permutations n +types+) do (terpri) (c-function (car comb) (cdr comb)) (terpri) (error "TODO: 3rd arg?") #|(c-callback (car comb) (cdr comb))|#))))) hunk ./tests/random-tester.lisp 210 (:pointer `(make-pointer ,n)) (t n)))))) +(defun string-starts-with-p (string1 string2) + "Answer whether STRING1 is a prefix of STRING2." + (let ((string1 (string string1)) (string2 (string string2))) + (and (>= (length string2) (length string1)) + (string= string1 string2 :end2 (length string1))))) + (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, hunk ./tests/random-tester.lisp 223 (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#))) + (string-starts-with-p "CFFI-RANDOM-TESTER-" + (package-name (symbol-package symbol)))) ;; lazy coding based on the definitions of `gen-function-test' ;; and `gen-callback-test' below hunk ./tests/random-tester.lisp 227 - (or (string= "DEFCFUN." symbol :end2 8) - (string= "CALLBACKS." symbol :end2 10)))) + (or (string-starts-with-p "DEFCFUN." symbol) + (string-starts-with-p "CALLBACKS." symbol)))) (defun gen-function-test (rettype arg-types) hunk ./tests/random-tester.lisp 231 + "Answer a function-call test creation form, and the RT test +name, as values." (let* ((fun-name (function-name rettype arg-types)) hunk ./tests/random-tester.lisp 234 - (fun-sym (cffi::lisp-function-name fun-name))) + (fun-sym (cffi::lisp-function-name fun-name)) + (test-name (cffi-utils:symbolicate '#:defcfun. fun-sym))) (multiple-value-bind (sum value-forms) (gen-arg-values rettype arg-types) hunk ./tests/random-tester.lisp 238 - `(progn - (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) - ,@(loop for type in arg-types and i from 1 collect - (list (cffi-utils:symbolicate '#:a (format nil "~A" i)) - (type-keyword type)))) - (deftest ,(cffi-utils:symbolicate '#:defcfun. fun-sym) - ,(integer-conversion (type-keyword rettype) - `(,fun-sym ,@value-forms)) - ,sum))))) + (values + `(progn + (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) + ,@(loop for type in arg-types and i from 1 collect + (list (cffi-utils:symbolicate '#:a (format nil "~A" i)) + (type-keyword type)))) + (deftest ,test-name + ,(integer-conversion (type-keyword rettype) + `(,fun-sym ,@value-forms)) + ,sum)) + test-name)))) (defun gen-callback-test (rettype arg-types sum) hunk ./tests/random-tester.lisp 251 + "Answer a callback test creation form, and the RT test name, as +values." (let* ((fname (function-name rettype arg-types)) (cb-sym (cffi::lisp-function-name fname)) (fun-name (concatenate 'string "call_" fname)) hunk ./tests/random-tester.lisp 258 (fun-sym (cffi::lisp-function-name fun-name)) (arg-names (loop for i from 1 upto (length arg-types) collect - (cffi-utils:symbolicate '#:a (format nil "~A" i))))) - `(progn - (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer)) - (defcallback ,cb-sym ,(type-keyword rettype) - ,(loop for type in arg-types and name in arg-names - collect (list name (type-keyword type))) - ,(integer-conversion - (type-keyword rettype) - `(+ ,@(mapcar (lambda (tp n) - (integer-conversion (type-keyword tp) n)) - arg-types arg-names)))) - (deftest ,(cffi-utils:symbolicate '#:callbacks. cb-sym) - ,(integer-conversion (type-keyword rettype) - `(,fun-sym (callback ,cb-sym))) - ,sum)))) + (cffi-utils:symbolicate '#:a (format nil "~A" i)))) + (test-name (cffi-utils:symbolicate '#:callbacks. cb-sym))) + (values + `(progn + (defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer)) + (defcallback ,cb-sym ,(type-keyword rettype) + ,(loop for type in arg-types and name in arg-names + collect (list name (type-keyword type))) + ,(integer-conversion + (type-keyword rettype) + `(+ ,@(mapcar (lambda (tp n) + (integer-conversion (type-keyword tp) n)) + arg-types arg-names)))) + (deftest ,test-name + ,(integer-conversion (type-keyword rettype) + `(,fun-sym (callback ,cb-sym))) + ,sum)) + test-name))) (defun cb-test (&key no-long-long) (let* ((rettype (find-type (if no-long-long :long :long-long))) hunk ./tests/random-tester.lisp 285 (args (random-sum rettype arg-types)) (sum (reduce #'+ args))) (c-callback rettype arg-types args) - (gen-callback-test rettype arg-types sum))) + (nth-value 0 (gen-callback-test rettype arg-types sum)))) ;;;; Temporary file generation hunk ./tests/random-tester.lisp 334 procedure :type "lisp" :defaults *test-pathname-defaults*)) +;;; TODO: "make" failure semantics + (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 hunk ./tests/random-tester.lisp 373 (call-with-temp-file (concatenate 'string *random-test-file-prefix* "mk") (lambda (mk-stream) + (format mk-stream "# Generated by random-tester.lisp, DO NOT EDIT!~%~%") (write-file-contents (make-pathname :name "Makefile" :type nil :defaults *test-pathname-defaults*) hunk ./tests/random-tester.lisp 378 mk-stream) + (fresh-line mk-stream) (funcall procedure mk-stream (make-target-maker (pathname mk-stream)))) :type nil :defaults *test-pathname-defaults*)) hunk ./tests/random-tester.lisp 385 ;;;; 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 +;;; see this in code, see `permutation-count'. Therefore, we have to +;;; choose our types carefully. Fortunately, `permutation-ref' makes ;;; this task much easier. hunk ./tests/random-tester.lisp 389 -(defun combinations (n items) +(defun permutations (n items) (let ((combs '())) (labels ((rec (n accum) (if (= n 0) hunk ./tests/random-tester.lisp 399 (rec n '()) combs))) -(defun combination-count (n items) - "Answer (length (combinations N ITEMS)) without computing them." +(defun permutation-count (n items) + "Answer (length (permutations N ITEMS)) without computing them." (expt (length items) n)) hunk ./tests/random-tester.lisp 403 -(defun combination-ref (n items x) - "Answer the Xth-computed N-tuple combination of ITEMS." +(defun permutation-ref (n items x) + "Answer the Xth-computed N-tuple permutation of ITEMS." (if (zerop n) '() (multiple-value-bind (quotient mod) (truncate x (length items)) hunk ./tests/random-tester.lisp 408 - (cons (nth mod items) (combination-ref (1- n) items quotient))))) + (cons (nth mod items) (permutation-ref (1- n) items quotient))))) (defun compute-test-type-set (item-count argcount) "Answer a list of ITEM-COUNT unique test type signatures. Each hunk ./tests/random-tester.lisp 415 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." +permutations." (incf argcount) ;treat RETTYPE uniformly (let* ((available-types (if (member 'cffi-features:no-long-long *features*) hunk ./tests/random-tester.lisp 423 (member k '(:long-long :unsigned-long-long))) +types+ :key #'type-keyword) +types+)) - (max-signatures (combination-count argcount available-types))) + (max-signatures (permutation-count argcount available-types))) (if (>= item-count max-signatures) hunk ./tests/random-tester.lisp 425 - (combinations argcount available-types) + (permutations 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. hunk ./tests/random-tester.lisp 431 (let ((signatures (make-hash-table :test 'eql :size item-count))) (labels ((next-sig (sig-num) - ;; Compute a random combination with linear clash + ;; Compute a random permutation with linear clash ;; resolution. (if (nth-value 1 (gethash sig-num signatures)) (next-sig (rem (1+ sig-num) max-signatures)) hunk ./tests/random-tester.lisp 439 (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)))))) + collect (permutation-ref argcount available-types sig-num)))))) ;;;; Test driver and result handling hunk ./tests/random-tester.lisp 450 (regression-test:pending-tests)) regression-test::*expected-failures*)) -(defun write-test-pair (type-signature c-stream lisp-stream) +(defun prepare-function-test (rettype argtypes c-stream lisp-stream) + "Helper for `prepare-test-pair'-Write the C and Lisp forms for +a callout test for a type signature on C-STREAM and LISP-STREAM. +Assume we are already in the correct I/O syntax and `*package*'. +Answer the RT test name." + (multiple-value-bind (function-test ft-name) + (gen-function-test rettype argtypes) + (c-function rettype argtypes c-stream) + (write function-test :stream lisp-stream :pretty t :circle t) + (fresh-line c-stream) + (fresh-line lisp-stream) + ft-name)) + +(defun prepare-callback-test (rettype argtypes c-stream lisp-stream) + "Helper for `prepare-test-pair'-Write the C and Lisp forms for +a callback test for a type signature on C-STREAM and LISP-STREAM. +Assume we are already in the correct I/O syntax and `*package*'. +Answer the RT test name." + (let ((callback-values (random-sum rettype argtypes))) + (multiple-value-bind (callback-test ct-name) + (gen-callback-test rettype argtypes + (reduce #'+ callback-values)) + (c-callback rettype argtypes callback-values c-stream) + (write callback-test + :stream lisp-stream :pretty t :circle t) + (fresh-line c-stream) + (fresh-line lisp-stream) + ct-name))) + +(defun prepare-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, hunk ./tests/random-tester.lisp 482 -respectively." +respectively. Answer the RT test names for the function and +callback tests as two values respectively." (destructuring-bind (rettype &rest argtypes) type-signature (with-standard-io-syntax (let ((*package* *test-package*)) hunk ./tests/random-tester.lisp 491 (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))))) + (multiple-value-prog1 + (values (prepare-function-test + . #0=(rettype argtypes c-stream lisp-stream)) + (prepare-callback-test . #0#)) + (terpri c-stream) + (terpri lisp-stream)))))) + +(defun shlib-target-name (c-filename) + "Answer the make target name to use for a shlib on C-FILENAME." + (concatenate 'string "lib" (pathname-name c-filename))) + +(defun write-c-preamble (c-stream) + "Write the preamble (before any tests) on C-STREAM." + (format c-stream + "/* Generated by random-tester.lisp, DO NOT EDIT! */ + +#include \"~A\"~%" *test-c-header*) (values)) hunk ./tests/random-tester.lisp 510 -(defun run-random-numeric-tests (&optional (each-test-count 250) - (min-argcount 1) (max-argcount 4)) +(defun write-lisp-preamble (lisp-stream c-filename) + "Write the preamble (before any tests) on LISP-STREAM." + (with-standard-io-syntax + (let ((*package* *test-package*) + (library-name (shlib-target-name c-filename)) + (library-symbol (intern *library-symbol-name* *test-package*))) + (dolist (pseudoform + ;; some items are not Lisp forms, so need to be written + ;; literally. For these purposes, a string is literal + ;; and anything else goes through `write'. + `(";;;; Generated by random-tester.lisp, DO NOT EDIT!" + (in-package ,(make-symbol (package-name *test-package*))) + ,(flet ((suffix-library-name (suffix) + (concatenate 'string library-name suffix))) + (let ((sofile (suffix-library-name ".so"))) + `(define-foreign-library ,library-symbol + (:unix (:or ,sofile ,(suffix-library-name "32.so"))) + (:darwin ,sofile) + (:windows ,(suffix-library-name ".dll") + "msvcrt.dll")))) + "(cl:defun load-directory () + (cl:let ((here #.(cl:or cl:*compile-file-truename* cl:*load-truename*))) + (cl:make-pathname :directory (cl:pathname-directory here))))" + "#-(:and :ecl (:not :dffi))" + (let ((*foreign-library-directories* + (list (,(intern "LOAD-DIRECTORY" *test-package*))))) + (load-foreign-library ',library-symbol)) + "#+(:and :ecl (:not :dffi))" + ,(format nil "(ffi:load-foreign-library + #.(cl:make-pathname :name ~S :type \"o\" + :defaults (cl:or cl:*compile-file-truename* + cl:*load-truename*)))" library-name))) + (if (stringp pseudoform) + (write-string pseudoform lisp-stream) + (write pseudoform :circle t :pretty t :stream lisp-stream)) + (terpri lisp-stream)))) + (values)) + +(defun prepare-make-target (makefile-stream shlib-target c-filename) + "Write target information on MAKEFILE-STREAM that will build a +shared library from the file attached to C-FILENAME. Afterwards, +invoking make using target SHLIB-TARGET, a string, should build +the library." + (let ((c-basename (namestring (make-pathname + :directory nil :defaults c-filename)))) + (fresh-line makefile-stream) + (format + makefile-stream + "RANDTESTLIBS = ~A$(SHLIB_EXT) + +ifeq ($(ARCH), x86_64) +RANDTESTLIBS += ~A32$(SHLIB_EXT) +endif + +~A: $(RANDTESTLIBS) + +~A$(SHLIB_EXT): ~A ~A + $(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $< + +ifeq ($(ARCH), x86_64) +~A32$(SHLIB_EXT): ~A ~A + $(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $< +endif~%" + shlib-target shlib-target shlib-target + shlib-target c-basename *test-c-header* + shlib-target c-basename *test-c-header*)) + (values)) + +(defun run-random-numeric-tests (&optional (each-test-count 50) + (min-argcount 1) (max-argcount 20)) "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 hunk ./tests/random-tester.lisp 584 reasonable. If there are test failures, keep the generated files -and print some (TODO: what?) information on `*error-output*'. -Answer something useful (TODO)." +and describe the failed tests on `*error-output*'. Answer the +number of failed tests." (let* ((*test-package* (make-package (format nil "CFFI-RANDOM-TESTER-~A" hunk ./tests/random-tester.lisp 592 (shiftf *gensym-counter* (1+ *gensym-counter*))) :use '())) ;; for `cffi-utils:symbolicate' and Lisp writing - (*package* *test-package*)) + (*package* *test-package*) + ;; HT of RT test name -> signature (ret . args) + (test-signatures + (make-hash-table + :test 'eq :size + ;; this size is just an estimate and may be *more* than + ;; the actual size + (loop for sigsize from (1+ min-argcount) to (1+ max-argcount) + sum (min each-test-count + (permutation-count sigsize +types+)))))) + (assert (eq *test-package* + (let ((sym (cffi-utils:symbolicate '#:a "B"))) + (prog1 (symbol-package sym) (unintern sym)))) + () "Assumption about SYMBOLICATE no longer valid") (unwind-protect hunk ./tests/random-tester.lisp 607 - (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|#)))))) + (progn + (call-with-c-test-file + (lambda (c-stream) + (write-c-preamble c-stream) + (call-with-lisp-test-file + (lambda (lisp-stream) + (write-lisp-preamble lisp-stream (pathname c-stream)) + (loop for argcount from min-argcount to max-argcount + do (dolist (chosen-test (compute-test-type-set + each-test-count argcount)) + (multiple-value-bind (ft-name ct-name) + (prepare-test-pair chosen-test + c-stream lisp-stream) + (setf (gethash ft-name test-signatures) + chosen-test + (gethash ct-name test-signatures) + chosen-test)))) + (call-with-makefile + (lambda (makefile-stream make-target-proc) + (let ((make-target (shlib-target-name (pathname c-stream)))) + (prepare-make-target makefile-stream make-target + (pathname c-stream)) + (mapc #'force-output + (list c-stream lisp-stream makefile-stream)) + (funcall make-target-proc make-target) + (load (compile-file (pathname lisp-stream)))))))))) + ;; FIXME: there is no current discrimination between these + ;; tests and other RT tests loaded. Perhaps this could be + ;; done with `rt:do-test'? + (regression-test:do-tests) + (let* ((failures (failed-tests-after-testing)) + (num-failures (length failures))) + (when (> num-failures 0) + (format *error-output* "~%RANDOM-TESTER found ~A failures:~%" + num-failures) + (dolist (failure failures) + (let ((signature (gethash failure test-signatures))) + (format *error-output* "~S signature: ~S ~A~%" + failure (type-keyword (first signature)) + (mapcar #'type-keyword (rest signature)))))) + num-failures)) (loop for sym being the present-symbols of *test-package* when (may-be-gentestname-p sym) hunk ./tests/random-tester.lisp 650 + ;; slower than saving the old test list and restoring it + ;; afterwards, but minimizing hacking on RT internals do (regression-test:rem-test sym)) hunk ./tests/random-tester.lisp 653 + ;; there is no public way to clean up the foreign library list. + ;; We recycle the same symbol-name every time because we get a + ;; different package every time. (delete-package *test-package*)))) ;; Notes: rt:*do-tests-when-defined* must be NIL while hunk ./tests/random-tester.lisp 664 ;; (defmacro define-function-and-callback-tests (min max) ;; `(progn ;; ,@(loop for n from min upto max appending -;; (loop for comb in (combinations n +types+) +;; (loop for comb in (permutations n +types+) ;; collect (gen-function-test (car comb) (cdr comb)) ;; collect (gen-callback-test (car comb) (cdr comb)))))) addfile ./tests/test-preamble.h hunk ./tests/test-preamble.h 1 +/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*- + * + * test-preamble.h --- preparation of C for written/generated tests + * + * Copyright (C) 2005, Luis Oliveira + * + * Permission is hereby granted, free of charge, to any person + * obtaining a copy of this software and associated documentation + * files (the "Software"), to deal in the Software without + * restriction, including without limitation the rights to use, copy, + * modify, merge, publish, distribute, sublicense, and/or sell copies + * of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be + * included in all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + * HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER + * DEALINGS IN THE SOFTWARE. + */ + +#ifdef WIN32 +#define DLLEXPORT __declspec(dllexport) +#else +#define DLLEXPORT +#endif + +#if 0 +/* what is this for? */ +DLLEXPORT char * dll_version = "20060830"; +#endif + +/* test-preamble.h ends here */ } Context: [Add long-long support to CLISP Luis Oliveira **20060627011858 Patch courtesy of Frédéric Jolliton. ] [ECL fixes Luis Oliveira **20060627010520 - cffi-ecl fixes: - push cffi-features:unix on darwin too. - use si:load-foreign-module instead of ffi:load-foreign-library on DFFI platforms. - use convert-external-name in foreign-symbol-pointer. - wrap defcvar's define-foreign-symbol around eval-when. - simplify default-library-suffix - cffi-tests: - load libtest.o on ECL platforms without DFFI. - conditionalize the tests with 127 arguments based on the value of lambda-parameters-limit. ] [review Foreign Types; add Glossary Stephen Compall **20060613205550] [uffi-compat: in load-foreign-library, don't probe for file if no directory. Nathan Bird **20060517201239 If it is just a filename without a directory, continue passing it down to the underlying functions, as they probably know how to find a library in default location.s The test now matches the uffi behaviour too. ] [Run tests both compiled and uncompiled. Luis Oliveira **20060607183000 - Make the test-suite run both with and without rt::*compile-tests* bound to T. ] [Huh. Found a very old and incomplete sentence in the manual. Luis Oliveira **20060607022358] [Minor comestic change in foreign-vars.lisp Luis Oliveira **20060607022335] [Lispworks bugfix: %mem-ref and %mem-set compiler macros Luis Oliveira **20060607022325 - The %mem-ref and %mem-set in cffi-lispworks.lisp were using bogus indexes. FLI's documentation suggests foreign-typed-aref expects array indexes but it seems to want offsets in bytes instead. - Regression tests: mem-ref.rt.1 and mem-ref.rt.2. ] [bugfix: accept symbols in defcvar Luis Oliveira **20060527020411 - Fix lisp-var-name to accept symbols. - Regression test: foreign-globals.symbol-name ] [Minor simplification in tests/bindings.lisp Luis Oliveira **20060526113626] [Fix some ECL bugs (maybe) Luis Oliveira **20060526113437 - Fixed some bitrot in cffi-ecl.lisp (maybe). Still can't test properly because of an ECL bug related to make-load-form. ] [Fix uffi-compat bugs Luis Oliveira **20060520181344 - :pointer is no longer a built-in type so we have to parse it, not find-type it. - def-array-pointer actually defines an array type with 1 element. (this emulates UFFI's behaviour) Bug report and initial patches courtesy of Lou Vanek. ] [Fix problem with declarations in DEFCALLBACKs Luis Oliveira **20060514234218 - Place declarations after the translations take place. - We no longer poke at ignore declarations in defcallback. ] [change first automatic defbitfield value to 1 Stephen Compall **20060512153832 - make-foreign-bitfield now starts implicit bitfield values at 1. No more special cases for zero. - Document and update bf tests to match. ] [defbitfield: explicit initial zero case Stephen Compall **20060511162202 - Provide for counting an initial zero as a pseudo-single-bit. - Test bitfield.4. ] [only single-bits affect defbitfield implicit values Stephen Compall **20060511154221 - Remove a case in which a non-single-bit like 3 could hijack the implicit value computation for defbitfield. - New test bitfield.3 for this behavior. ] [Fix defbitfield bug and new test Luis Oliveira **20060511145035 - Bug fix: when the first value was provided a (< foo nil) comparision would occur. Regresion test: bitfield.1. - New test bitfield.2. ] [implicit defbitfield symbol values Stephen Compall **20060511072106 - Foreign Type Translators: defctype does not create Lisp types; you have to use eql specializers. - enum.lisp: Use reduce in %foreign-bitfield-value. Code a default rule for bitfield symbol values. ] [Make :POINTER a parameterized foreign type. James Bielman **20060507003511 - :POINTER without arguments is a void pointer. - (:POINTER :INT) is a pointer to an :INT. - These nest properly: (:POINTER (:POINTER :INT)). - Pointers are not type checked yet---an optional pointer type checker will be added someday. ] [Bugfix: Quote type arguments to %DEFCFUN-VARARGS. James Bielman **20060507002829] [Recognize OpenMCL/X86-64 and set CFFI features accordingly. James Bielman **20060504173940] [Conditionalize against non-CPU specific word-size features in OpenMCL. James Bielman **20060504021623] [Bugfix: Specialize UNPARSE for UFFI-CHAR in CFFI-UFFI-COMPAT. James Bielman **20060504015421 - Fixes an error when loading FASL files that dumped UFFI-CHAR instead of (UFFI-CHAR :CHAR) using MAKE-LOAD-FORM. - Reported by Ricardo Boccato. ] [More copyright header year updates. James Bielman **20060503064225] [Update copyright year in file headers. James Bielman **20060503063944] [Conditionally set variables for implementations in Makefile. James Bielman **20060503063241 - Allow overriding from the environment as suggest in the comment, which didn't actually work. (eg.: OPENMCL=openmcl64 make test) ] [Add OpenMCL/X86-64 fasl files to 'make clean'. James Bielman **20060503061637] [Make corman's finalizers thread-safe (hopefully) Luis Oliveira **20060424173620] [Add support for finalizers Luis Oliveira **20060424025357 - New functions: finalize and cancel-finalization. - New cffi-"feature": no-finalizers. Only ECL pushes this. - Document new functions. ] [Include stdint.h in libtest.c Luis Oliveira **20060424025320] [Oops, forgot to bump the version number. Luis Oliveira **20060424025119] [TAG 0.9.1 Luis Oliveira **20060418011351] Patch bundle hash: 0e604380afa14228c95c35652e4cebbffd84d70a