Permalink
Fetching contributors…
Cannot retrieve contributors at this time
537 lines (440 sloc) 19.5 KB
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; defcfun.lisp --- Tests function definition and calling.
;;;
;;; Copyright (C) 2005-2007, 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)
(deftest defcfun.parse-name-and-options.1
(multiple-value-bind (lisp-name foreign-name)
(let ((*package* (find-package '#:cffi-tests)))
(cffi::parse-name-and-options "foo_bar"))
(list lisp-name foreign-name))
(foo-bar "foo_bar"))
(deftest defcfun.parse-name-and-options.2
(multiple-value-bind (lisp-name foreign-name)
(let ((*package* (find-package '#:cffi-tests)))
(cffi::parse-name-and-options "foo_bar" t))
(list lisp-name foreign-name))
(*foo-bar* "foo_bar"))
(deftest defcfun.parse-name-and-options.3
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options 'foo-bar)
(list lisp-name foreign-name))
(foo-bar "foo_bar"))
(deftest defcfun.parse-name-and-options.4
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '*foo-bar* t)
(list lisp-name foreign-name))
(*foo-bar* "foo_bar"))
(deftest defcfun.parse-name-and-options.5
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '("foo_bar" foo-baz))
(list lisp-name foreign-name))
(foo-baz "foo_bar"))
(deftest defcfun.parse-name-and-options.6
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '("foo_bar" *foo-baz*) t)
(list lisp-name foreign-name))
(*foo-baz* "foo_bar"))
(deftest defcfun.parse-name-and-options.7
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '(foo-baz "foo_bar"))
(list lisp-name foreign-name))
(foo-baz "foo_bar"))
(deftest defcfun.parse-name-and-options.8
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '(*foo-baz* "foo_bar") t)
(list lisp-name foreign-name))
(*foo-baz* "foo_bar"))
;;;# Name translation
(deftest translate-underscore-separated-name.to-symbol
(let ((*package* (find-package '#:cffi-tests)))
(translate-underscore-separated-name "some_name_with_underscores"))
some-name-with-underscores)
(deftest translate-underscore-separated-name.to-string
(translate-underscore-separated-name 'some-name-with-underscores)
"some_name_with_underscores")
(deftest translate-camelcase-name.to-symbol
(let ((*package* (find-package '#:cffi-tests)))
(translate-camelcase-name "someXmlFunction"))
some-xml-function)
(deftest translate-camelcase-name.to-string
(translate-camelcase-name 'some-xml-function)
"someXmlFunction")
(deftest translate-camelcase-name.to-string-upper
(translate-camelcase-name 'some-xml-function :upper-initial-p t)
"SomeXmlFunction")
(deftest translate-camelcase-name.to-symbol-special
(let ((*package* (find-package '#:cffi-tests)))
(translate-camelcase-name "someXMLFunction" :special-words '("XML")))
some-xml-function)
(deftest translate-camelcase-name.to-string-special
(translate-camelcase-name 'some-xml-function :special-words '("XML"))
"someXMLFunction")
(deftest translate-name-from-foreign.function
(let ((*package* (find-package '#:cffi-tests)))
(translate-name-from-foreign "some_xml_name" *package*))
some-xml-name)
(deftest translate-name-from-foreign.var
(let ((*package* (find-package '#:cffi-tests)))
(translate-name-from-foreign "some_xml_name" *package* t))
*some-xml-name*)
(deftest translate-name-to-foreign.function
(translate-name-to-foreign 'some-xml-name *package*)
"some_xml_name")
(deftest translate-name-to-foreign.var
(translate-name-to-foreign '*some-xml-name* *package* t)
"some_xml_name")
;;;# Calling with built-in c types
;;;
;;; Tests calling standard C library functions both passing
;;; and returning each built-in type. (adapted from funcall.lisp)
(defcfun "toupper" :char
"toupper docstring"
(char :char))
(deftest defcfun.char
(toupper (char-code #\a))
#.(char-code #\A))
(deftest defcfun.docstring
(documentation 'toupper 'function)
"toupper docstring")
(defcfun ("abs" c-abs) :int
(n :int))
(deftest defcfun.int
(c-abs -100)
100)
(defcfun "labs" :long
(n :long))
(deftest defcfun.long
(labs -131072)
131072)
#-cffi-features:no-long-long
(progn
(defcfun "my_llabs" :long-long
(n :long-long))
(deftest defcfun.long-long
(my-llabs -9223372036854775807)
9223372036854775807)
(defcfun "ullong" :unsigned-long-long
(n :unsigned-long-long))
#+allegro ; lp#914500
(pushnew 'defcfun.unsigned-long-long rt::*expected-failures*)
(deftest defcfun.unsigned-long-long
(let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
(eql ullong-max (ullong ullong-max)))
t))
(defcfun "my_sqrtf" :float
(n :float))
(deftest defcfun.float
(my-sqrtf 16.0)
4.0)
(defcfun ("sqrt" c-sqrt) :double
(n :double))
(deftest defcfun.double
(c-sqrt 36.0d0)
6.0d0)
#+(and scl long-float)
(defcfun ("sqrtl" c-sqrtl) :long-double
(n :long-double))
#+(and scl long-float)
(deftest defcfun.long-double
(c-sqrtl 36.0l0)
6.0l0)
(defcfun "strlen" :int
(n :string))
(deftest defcfun.string.1
(strlen "Hello")
5)
(defcfun "strcpy" (:pointer :char)
(dest (:pointer :char))
(src :string))
(defcfun "strcat" (:pointer :char)
(dest (:pointer :char))
(src :string))
(deftest defcfun.string.2
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(strcpy s "Hello")
(strcat s ", world!"))
"Hello, world!")
(defcfun "strerror" :string
(n :int))
(deftest defcfun.string.3
(typep (strerror 1) 'string)
t)
;;; Regression test. Allegro would warn on direct calls to
;;; functions with no arguments.
;;;
;;; Also, let's check if void functions will return NIL.
;;;
;;; Check if a docstring without arguments doesn't cause problems.
(defcfun "noargs" :int
"docstring")
(deftest defcfun.noargs
(noargs)
42)
(defcfun "noop" :void)
#+(or allegro openmcl ecl) (pushnew 'defcfun.noop rt::*expected-failures*)
(deftest defcfun.noop
(noop)
#|no values|#)
;;;# Calling varargs functions
(defcfun "sum_double_arbitrary" :double (n :int) &rest)
(deftest defcfun.varargs.nostdlib
(sum-double-arbitrary
26
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0)
81.64d0)
(defcfun "sprintf" :int
"sprintf docstring"
(str (:pointer :char))
(control :string)
&rest)
;;; CLISP and ABCL discard macro docstrings.
#+(or clisp abcl)
(pushnew 'defcfun.varargs.docstrings rt::*expected-failures*)
(deftest defcfun.varargs.docstrings
(documentation 'sprintf 'function)
"sprintf docstring")
(deftest defcfun.varargs.char
(with-foreign-pointer-as-string (s 100)
(sprintf s "%c" :char 65))
"A")
(deftest defcfun.varargs.short
(with-foreign-pointer-as-string (s 100)
(sprintf s "%d" :short 42))
"42")
(deftest defcfun.varargs.int
(with-foreign-pointer-as-string (s 100)
(sprintf s "%d" :int 1000))
"1000")
(deftest defcfun.varargs.long
(with-foreign-pointer-as-string (s 100)
(sprintf s "%ld" :long 131072))
"131072")
(deftest defcfun.varargs.float
(with-foreign-pointer-as-string (s 100)
(sprintf s "%.2f" :float (float pi)))
"3.14")
(deftest defcfun.varargs.double
(with-foreign-pointer-as-string (s 100)
(sprintf s "%.2f" :double (float pi 1.0d0)))
"3.14")
#+(and scl long-float)
(deftest defcfun.varargs.long-double
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(sprintf s "%.2Lf" :long-double pi))
"3.14")
(deftest defcfun.varargs.string
(with-foreign-pointer-as-string (s 100)
(sprintf s "%s, %s!" :string "Hello" :string "world"))
"Hello, world!")
;;; (let ((rettype (find-type :long))
;;; (arg-types (n-random-types-no-ll 127)))
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
#+(and (not ecl)
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)))
(progn
(defcfun "sum_127_no_ll" :long
(a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
(a6 :double) (a7 :unsigned-long) (a8 :float) (a9 :unsigned-char)
(a10 :unsigned-short) (a11 :short) (a12 :unsigned-long) (a13 :double)
(a14 :long) (a15 :unsigned-int) (a16 :pointer) (a17 :unsigned-int)
(a18 :unsigned-short) (a19 :long) (a20 :float) (a21 :pointer) (a22 :float)
(a23 :int) (a24 :int) (a25 :unsigned-short) (a26 :long) (a27 :long)
(a28 :double) (a29 :unsigned-char) (a30 :unsigned-int) (a31 :unsigned-int)
(a32 :int) (a33 :unsigned-short) (a34 :unsigned-int) (a35 :pointer)
(a36 :double) (a37 :double) (a38 :long) (a39 :short) (a40 :unsigned-short)
(a41 :long) (a42 :char) (a43 :long) (a44 :unsigned-short) (a45 :pointer)
(a46 :int) (a47 :unsigned-int) (a48 :double) (a49 :unsigned-char)
(a50 :unsigned-char) (a51 :float) (a52 :int) (a53 :unsigned-short)
(a54 :double) (a55 :short) (a56 :unsigned-char) (a57 :unsigned-long)
(a58 :float) (a59 :float) (a60 :float) (a61 :pointer) (a62 :pointer)
(a63 :unsigned-int) (a64 :unsigned-long) (a65 :char) (a66 :short)
(a67 :unsigned-short) (a68 :unsigned-long) (a69 :pointer) (a70 :float)
(a71 :double) (a72 :long) (a73 :unsigned-long) (a74 :short)
(a75 :unsigned-int) (a76 :unsigned-short) (a77 :int) (a78 :unsigned-short)
(a79 :char) (a80 :double) (a81 :short) (a82 :unsigned-char) (a83 :float)
(a84 :char) (a85 :int) (a86 :double) (a87 :unsigned-char) (a88 :int)
(a89 :unsigned-long) (a90 :double) (a91 :short) (a92 :short)
(a93 :unsigned-int) (a94 :unsigned-char) (a95 :float) (a96 :long)
(a97 :float) (a98 :long) (a99 :long) (a100 :int) (a101 :int)
(a102 :unsigned-int) (a103 :char) (a104 :char) (a105 :unsigned-short)
(a106 :unsigned-int) (a107 :unsigned-short) (a108 :unsigned-short)
(a109 :int) (a110 :long) (a111 :char) (a112 :double) (a113 :unsigned-int)
(a114 :char) (a115 :short) (a116 :unsigned-long) (a117 :unsigned-int)
(a118 :short) (a119 :unsigned-char) (a120 :float) (a121 :pointer)
(a122 :double) (a123 :int) (a124 :long) (a125 :char) (a126 :unsigned-short)
(a127 :float))
(deftest defcfun.bff.1
(sum-127-no-ll
1442906394 520035521 -4715 50335 -13557.0 -30892.0d0 24061483 -23737.0
22 2348 4986 104895680 8073.0d0 -571698147 102484400
(make-pointer 507907275) 12733353 7824 -1275845284 13602.0
(make-pointer 286958390) -8042.0 -773681663 -1289932452 31199 -154985357
-170994216 16845.0d0 177 218969221 2794350893 6068863 26327 127699339
(make-pointer 184352771) 18512.0d0 -12345.0d0 -179853040 -19981 37268
-792845398 116 -1084653028 50494 (make-pointer 2105239646) -1710519651
1557813312 2839.0d0 90 180 30580.0 -532698978 8623 9537.0d0 -10882 54
184357206 14929.0 -8190.0 -25615.0 (make-pointer 235310526)
(make-pointer 220476977) 7476055 1576685 -117 -11781 31479 23282640
(make-pointer 8627281) -17834.0 10391.0d0 -1904504370 114393659 -17062
637873619 16078 -891210259 8107 0 760.0d0 -21268 104 14133.0 10
588598141 310.0d0 20 1351785456 16159552 -10121.0d0 -25866 24821
68232851 60 -24132.0 -1660411658 13387.0 -786516668 -499825680
-1128144619 111849719 2746091587 -2 95 14488 326328135 64781 18204
150716680 -703859275 103 16809.0d0 852235610 -43 21088 242356110
324325428 -22380 23 24814.0 (make-pointer 40362014) -14322.0d0
-1864262539 523684371 -21 49995 -29175.0)
796447501))
;;; (let ((rettype (find-type :long-long))
;;; (arg-types (n-random-types 127)))
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
#-(or ecl cffi-sys::no-long-long
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(progn
(defcfun "sum_127" :long-long
(a1 :pointer) (a2 :pointer) (a3 :float) (a4 :unsigned-long) (a5 :pointer)
(a6 :long-long) (a7 :double) (a8 :double) (a9 :unsigned-short) (a10 :int)
(a11 :long-long) (a12 :long) (a13 :short) (a14 :unsigned-int) (a15 :long)
(a16 :unsigned-char) (a17 :int) (a18 :double) (a19 :short) (a20 :short)
(a21 :long-long) (a22 :unsigned-int) (a23 :unsigned-short) (a24 :short)
(a25 :pointer) (a26 :short) (a27 :unsigned-short) (a28 :unsigned-short)
(a29 :int) (a30 :long-long) (a31 :pointer) (a32 :int) (a33 :unsigned-long)
(a34 :unsigned-long) (a35 :pointer) (a36 :unsigned-long-long) (a37 :float)
(a38 :int) (a39 :short) (a40 :pointer) (a41 :unsigned-long-long)
(a42 :long-long) (a43 :unsigned-long) (a44 :unsigned-long)
(a45 :unsigned-long-long) (a46 :unsigned-long) (a47 :char) (a48 :double)
(a49 :long) (a50 :unsigned-int) (a51 :int) (a52 :short) (a53 :pointer)
(a54 :long) (a55 :unsigned-long-long) (a56 :int) (a57 :unsigned-short)
(a58 :unsigned-long-long) (a59 :float) (a60 :pointer) (a61 :float)
(a62 :unsigned-short) (a63 :unsigned-long) (a64 :float) (a65 :unsigned-int)
(a66 :unsigned-long-long) (a67 :pointer) (a68 :double)
(a69 :unsigned-long-long) (a70 :double) (a71 :double) (a72 :long-long)
(a73 :pointer) (a74 :unsigned-short) (a75 :long) (a76 :pointer) (a77 :short)
(a78 :double) (a79 :long) (a80 :unsigned-char) (a81 :pointer)
(a82 :unsigned-char) (a83 :long) (a84 :double) (a85 :pointer) (a86 :int)
(a87 :double) (a88 :unsigned-char) (a89 :double) (a90 :short) (a91 :long)
(a92 :int) (a93 :long) (a94 :double) (a95 :unsigned-short)
(a96 :unsigned-int) (a97 :int) (a98 :char) (a99 :long-long) (a100 :double)
(a101 :float) (a102 :unsigned-long) (a103 :short) (a104 :pointer)
(a105 :float) (a106 :long-long) (a107 :int) (a108 :long-long)
(a109 :long-long) (a110 :double) (a111 :unsigned-long-long) (a112 :double)
(a113 :unsigned-long) (a114 :char) (a115 :char) (a116 :unsigned-long)
(a117 :short) (a118 :unsigned-char) (a119 :unsigned-char) (a120 :int)
(a121 :int) (a122 :float) (a123 :unsigned-char) (a124 :unsigned-char)
(a125 :double) (a126 :unsigned-long-long) (a127 :char))
#+(and sbcl x86) (push 'defcfun.bff.2 rtest::*expected-failures*)
(deftest defcfun.bff.2
(sum-127
(make-pointer 2746181372) (make-pointer 177623060) -32334.0 3158055028
(make-pointer 242315091) 4288001754991016425 -21047.0d0 287.0d0 18722
243379286 -8677366518541007140 581399424 -13872 4240394881 1353358999
226 969197676 -26207.0d0 6484 11150 1241680089902988480 106068320 61865
2253 (make-pointer 866809333) -31613 35616 11715 1393601698
8940888681199591845 (make-pointer 1524606024) 805638893 3315410736
3432596795 (make-pointer 1490355706) 696175657106383698 -25438.0
1294381547 26724 (make-pointer 3196569545) 2506913373410783697
-4405955718732597856 4075932032 3224670123 2183829215657835866
1318320964 -22 -3786.0d0 -2017024146 1579225515 -626617701 -1456
(make-pointer 3561444187) 395687791 1968033632506257320 -1847773261
48853 142937735275669133 -17974.0 (make-pointer 2791749948) -14140.0
2707 3691328585 3306.0 1132012981 303633191773289330
(make-pointer 981183954) 9114.0d0 8664374572369470 -19013.0d0
-10288.0d0 -3679345119891954339 (make-pointer 3538786709) 23761
-154264605 (make-pointer 2694396308) 7023 997.0d0 1009561368 241
(make-pointer 2612292671) 48 1431872408 -32675.0d0
(make-pointer 1587599336) 958916472 -9857.0d0 111 -14370.0d0 -7308
-967514912 488790941 2146978095 -24111.0d0 13711 86681861 717987770
111 1013402998690933877 17234.0d0 -8772.0 3959216275 -8711
(make-pointer 3142780851) 9480.0 -3820453146461186120 1616574376
-3336232268263990050 -1906114671562979758 -27925.0d0 9695970875869913114
27033.0d0 1096518219 -12 104 3392025403 -27911 60 89 509297051
-533066551 29158.0 110 54 -9802.0d0 593950442165910888 -79)
7758614658402721936))
;;; regression test: defining an undefined foreign function should only
;;; throw some sort of warning, not signal an error.
#+(or cmucl (and sbcl (or (not linkage-table) win32)))
(pushnew 'defcfun.undefined rt::*expected-failures*)
(deftest defcfun.undefined
(progn
(eval '(defcfun ("undefined_foreign_function" undefined-foreign-function) :void))
(compile 'undefined-foreign-function)
t)
t)
;;; Test whether all doubles are passed correctly. On some platforms, eg.
;;; darwin/ppc, some are passed on registers others on the stack.
(defcfun "sum_double26" :double
(a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
(a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
(a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
(a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
(a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
(a26 :double))
(deftest defcfun.double26
(sum-double26 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0)
81.64d0)
;;; Same as above for floats.
(defcfun "sum_float26" :float
(a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
(a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
(a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
(a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
(a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
(a26 :float))
(deftest defcfun.float26
(sum-float26 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0
5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0)
130.0)
;;;# Namespaces
#-cffi-sys::flat-namespace
(progn
(defcfun ("ns_function" ns-fun1 :library libtest) :boolean)
(defcfun ("ns_function" ns-fun2 :library libtest2) :boolean)
(deftest defcfun.namespace.1
(values (ns-fun1) (ns-fun2))
t nil))
;;;# stdcall
#+(and x86 windows (not cffi-sys::no-stdcall))
(progn
(defcfun ("stdcall_fun@12" stdcall-fun :convention :stdcall) :int
(a :int)
(b :int)
(c :int))
(deftest defcfun.stdcall.1
(loop repeat 100 do (stdcall-fun 1 2 3)
finally (return (stdcall-fun 1 2 3)))
6))