[cells-cvs] CVS cells-gtk/cffi/tests
ktilton
ktilton at common-lisp.net
Mon Jan 28 23:59:38 UTC 2008
Update of /project/cells/cvsroot/cells-gtk/cffi/tests
In directory clnet:/tmp/cvs-serv9292/cffi/tests
Added Files:
Makefile bindings.lisp callbacks.lisp compile.bat defcfun.lisp
enum.lisp foreign-globals.lisp funcall.lisp libtest.c
memory.lisp misc-types.lisp misc.lisp package.lisp
random-tester.lisp run-tests.lisp struct.lisp union.lisp
Log Message:
--- /project/cells/cvsroot/cells-gtk/cffi/tests/Makefile 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/Makefile 2008/01/28 23:59:38 1.1
# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for various tasks.
#
# Copyright (C) 2005, James Bielman <jamesjb at jamesjb.com>
#
# 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.
#
OSTYPE = $(shell uname)
CC := gcc
CFLAGS := -lm -Wall -std=c99 -pedantic
SHLIB_CFLAGS := -shared
SHLIB_EXT := .so
ifneq ($(if $(findstring $(OSTYPE),Linux FreeBSD),OK), OK)
ifeq ($(OSTYPE), Darwin)
SHLIB_CFLAGS := -bundle
else
ifeq ($(OSTYPE), SunOS)
CFLAGS := -c -Wall -std=c99 -pedantic
else
# Let's assume this is win32
SHLIB_EXT := .dll
endif
endif
endif
ARCH = $(shell uname -m)
ifeq ($(ARCH), x86_64)
CFLAGS += -fPIC
endif
# Are all G5s ppc970s?
ifeq ($(ARCH), ppc970)
CFLAGS += -m64
endif
SHLIBS = libtest$(SHLIB_EXT)
ifeq ($(ARCH), x86_64)
SHLIBS += libtest32$(SHLIB_EXT)
endif
shlibs: $(SHLIBS)
libtest$(SHLIB_EXT): libtest.c
$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
ifeq ($(ARCH), x86_64)
libtest32$(SHLIB_EXT): libtest.c
$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
endif
clean:
rm -f *.so *.dylib *.dll *.bundle
# vim: ft=make ts=3 noet
--- /project/cells/cvsroot/cells-gtk/cffi/tests/bindings.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/bindings.lisp 2008/01/28 23:59:38 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; libtest.lisp --- Setup CFFI bindings for libtest.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; 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.
;;;
(in-package #:cffi-tests)
(define-foreign-library libtest
(:unix (:or "libtest.so" "libtest32.so"))
(:darwin "libtest.so")
(:windows "libtest.dll" "msvcrt.dll"))
;;; Return the directory containing the source when compiling or
;;; loading this file. We don't use *LOAD-TRUENAME* because the fasl
;;; file may be in a different directory than the source with certain
;;; ASDF extensions loaded.
(defun load-directory ()
(let ((here #.(or *compile-file-truename* *load-truename*)))
(make-pathname :directory (pathname-directory here))))
#-(:and :ecl (:not :dffi))
(let ((*foreign-library-directories* (list (load-directory))))
(load-foreign-library 'libtest))
#+(:and :ecl (:not :dffi))
(ffi:load-foreign-library
#.(make-pathname :name "libtest" :type "o"
:defaults (or *compile-file-truename* *load-truename*)))
;;; check libtest version
(defparameter *required-dll-version* "20060414")
(defcvar "dll_version" :string)
(unless (string= *dll-version* *required-dll-version*)
(error "version check failed: expected ~s but libtest reports ~s"
*required-dll-version*
*dll-version*))
;;; The maximum and minimum values for single and double precision C
;;; floating point values, which may be quite different from the
;;; corresponding Lisp versions.
(defcvar "float_max" :float)
(defcvar "float_min" :float)
(defcvar "double_max" :double)
(defcvar "double_min" :double)
;;; This is not the best place for this code...
(defparameter *repeat* 1)
(defun run-cffi-tests (&key (compiled nil))
(let ((rt::*compile-tests* compiled)
(*package* (find-package '#:cffi-tests)))
(format t "~2&How many times shall we run the tests (~Acompiled)? [~D]: "
(if compiled "" "un") *repeat*)
(force-output *standard-output*)
(let* ((ntimes (or (ignore-errors (parse-integer (read-line))) *repeat*))
(ret-values (loop repeat ntimes collect (do-tests))))
(format t "~&;;; Finished running tests (~Acompiled) ~D times."
(if compiled "" "un") ntimes)
(every #'identity ret-values))))--- /project/cells/cvsroot/cells-gtk/cffi/tests/callbacks.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/callbacks.lisp 2008/01/28 23:59:38 1.1
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; callbacks.lisp --- Tests on callbacks.
;;;
;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; 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.
;;;
(in-package #:cffi-tests)
(defcfun "expect_char_sum" :int (f :pointer))
(defcfun "expect_unsigned_char_sum" :int (f :pointer))
(defcfun "expect_short_sum" :int (f :pointer))
(defcfun "expect_unsigned_short_sum" :int (f :pointer))
(defcfun "expect_int_sum" :int (f :pointer))
(defcfun "expect_unsigned_int_sum" :int (f :pointer))
(defcfun "expect_long_sum" :int (f :pointer))
(defcfun "expect_unsigned_long_sum" :int (f :pointer))
(defcfun "expect_float_sum" :int (f :pointer))
(defcfun "expect_double_sum" :int (f :pointer))
(defcfun "expect_pointer_sum" :int (f :pointer))
(defcfun "expect_strcat" :int (f :pointer))
#-cffi-features:no-long-long
(progn
(defcfun "expect_long_long_sum" :int (f :pointer))
(defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))
#+(and scl long-float)
(defcfun "expect_long_double_sum" :int (f :pointer))
(defcallback sum-char :char ((a :char) (b :char))
"Test if the named block is present and the docstring too."
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(return-from sum-char (+ a b)))
(defcallback sum-unsigned-char :unsigned-char
((a :unsigned-char) (b :unsigned-char))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-short :short ((a :short) (b :short))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-unsigned-short :unsigned-short
((a :unsigned-short) (b :unsigned-short))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-int :int ((a :int) (b :int))
(+ a b))
(defcallback sum-unsigned-int :unsigned-int
((a :unsigned-int) (b :unsigned-int))
(+ a b))
(defcallback sum-long :long ((a :long) (b :long))
(+ a b))
(defcallback sum-unsigned-long :unsigned-long
((a :unsigned-long) (b :unsigned-long))
(+ a b))
#-cffi-features:no-long-long
(progn
(defcallback sum-long-long :long-long
((a :long-long) (b :long-long))
(+ a b))
(defcallback sum-unsigned-long-long :unsigned-long-long
((a :unsigned-long-long) (b :unsigned-long-long))
(+ a b)))
(defcallback sum-float :float ((a :float) (b :float))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-double :double ((a :double) (b :double))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
#+(and scl long-float)
(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
(inc-pointer ptr offset))
(defcallback lisp-strcat :string ((a :string) (b :string))
(concatenate 'string a b))
(deftest callbacks.char
(expect-char-sum (get-callback 'sum-char))
1)
(deftest callbacks.unsigned-char
(expect-unsigned-char-sum (get-callback 'sum-unsigned-char))
1)
(deftest callbacks.short
(expect-short-sum (callback sum-short))
1)
(deftest callbacks.unsigned-short
(expect-unsigned-short-sum (callback sum-unsigned-short))
1)
(deftest callbacks.int
(expect-int-sum (callback sum-int))
1)
(deftest callbacks.unsigned-int
(expect-unsigned-int-sum (callback sum-unsigned-int))
1)
(deftest callbacks.long
(expect-long-sum (callback sum-long))
1)
(deftest callbacks.unsigned-long
(expect-unsigned-long-sum (callback sum-unsigned-long))
1)
#-cffi-features:no-long-long
(progn
#+openmcl (push 'callbacks.long-long rt::*expected-failures*)
(deftest callbacks.long-long
(expect-long-long-sum (callback sum-long-long))
1)
(deftest callbacks.unsigned-long-long
(expect-unsigned-long-long-sum (callback sum-unsigned-long-long))
1))
(deftest callbacks.float
(expect-float-sum (callback sum-float))
1)
(deftest callbacks.double
(expect-double-sum (callback sum-double))
1)
#+(and scl long-float)
(deftest callbacks.long-double
(expect-long-double-sum (callback sum-long-double))
1)
(deftest callbacks.pointer
(expect-pointer-sum (callback sum-pointer))
1)
(deftest callbacks.string
(expect-strcat (callback lisp-strcat))
1)
#-cffi-features:no-foreign-funcall
(defcallback return-a-string-not-nil :string ()
"abc")
#-cffi-features:no-foreign-funcall
(deftest callbacks.string-not-docstring
(foreign-funcall (callback return-a-string-not-nil) :string)
"abc")
;;; This one tests mem-aref too.
(defcfun "qsort" :void
(base :pointer)
(nmemb :int)
(size :int)
(fun-compar :pointer))
(defcallback < :int ((a :pointer) (b :pointer))
(let ((x (mem-ref a :int))
(y (mem-ref b :int)))
(cond ((> x y) 1)
((< x y) -1)
(t 0))))
(deftest callbacks.qsort
(with-foreign-object (array :int 10)
;; Initialize array.
(loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
do (setf (mem-aref array :int i) n))
;; Sort it.
(qsort array 10 (foreign-type-size :int) (callback <))
;; Return it as a list.
(loop for i from 0 below 10
collect (mem-aref array :int i)))
(1 2 3 4 5 6 7 8 9 10))
;;; void callback
(defparameter *int* -1)
(defcfun "pass_int_ref" :void (f :pointer))
;;; CMUCL chokes on this one for some reason.
#-(and cffi-features:darwin cmu)
(defcallback read-int-from-pointer :void ((a :pointer))
(setq *int* (mem-ref a :int)))
#+(and cffi-features:darwin cmu)
(pushnew 'callbacks.void rt::*expected-failures*)
(deftest callbacks.void
(progn
(pass-int-ref (callback read-int-from-pointer))
*int*)
1984)
;;; test funcalling of a callback and also declarations inside
;;; callbacks.
#-cffi-features:no-foreign-funcall
(progn
(defcallback sum-2 :int ((a :int) (b :int) (c :int))
(declare (ignore c))
(+ a b))
[254 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/compile.bat 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/compile.bat 2008/01/28 23:59:38 1.1
[260 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/defcfun.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/defcfun.lisp 2008/01/28 23:59:38 1.1
[621 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/enum.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/enum.lisp 2008/01/28 23:59:38 1.1
[736 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/foreign-globals.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/foreign-globals.lisp 2008/01/28 23:59:38 1.1
[973 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/funcall.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/funcall.lisp 2008/01/28 23:59:38 1.1
[1146 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/libtest.c 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/libtest.c 2008/01/28 23:59:38 1.1
[1925 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/memory.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/memory.lisp 2008/01/28 23:59:38 1.1
[2461 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/misc-types.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/misc-types.lisp 2008/01/28 23:59:38 1.1
[2694 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/misc.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/misc.lisp 2008/01/28 23:59:38 1.1
[2783 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/package.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/package.lisp 2008/01/28 23:59:38 1.1
[2815 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/random-tester.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/random-tester.lisp 2008/01/28 23:59:38 1.1
[3061 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/run-tests.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/run-tests.lisp 2008/01/28 23:59:38 1.1
[3106 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/struct.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/struct.lisp 2008/01/28 23:59:38 1.1
[3402 lines skipped]
--- /project/cells/cvsroot/cells-gtk/cffi/tests/union.lisp 2008/01/28 23:59:38 NONE
+++ /project/cells/cvsroot/cells-gtk/cffi/tests/union.lisp 2008/01/28 23:59:38 1.1
[3452 lines skipped]
More information about the Cells-cvs
mailing list