Add support for ECL long double

[cffi.git] / tests / defcfun.lisp

;;;; -*- 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 rtest::*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 (or ecl scl) long-float)
(defcfun ("sqrtl" c-sqrtl) :long-double
  (n :long-double))

#+(and (or ecl 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 rtest::*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 rtest::*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 "%.0f" :float (* pi 100)))
  "314")

(deftest defcfun.varargs.double
    (with-foreign-pointer-as-string (s 100)
      (sprintf s "%.0f" :double (* pi 100d0)))
  "314")

#+(and (or ecl scl) long-float)
(deftest defcfun.varargs.long-double
    (with-foreign-pointer-as-string (s 100)
      (setf (mem-ref s :char) 0)
      (sprintf s "%.0Lf" :long-double (* pi 100)))
  "314")

(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.

#+(and sbcl win32)
(pushnew 'defcfun.undefined rtest::*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))