[cells-cvs] CVS cells-gtk/cffi/tests - cells-cvs@common-lisp.net - mailman3.common-lisp.net

29 Jan 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@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]