tests/funcall.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; funcall.lisp --- Tests function calling.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, James Bielman  <jamesjb@jamesjb.com>
   6 ;;; Copyright (C) 2005-2007, Luis Oliveira  <loliveira@common-lisp.net>
   7 ;;;
   8 ;;; Permission is hereby granted, free of charge, to any person
   9 ;;; obtaining a copy of this software and associated documentation
  10 ;;; files (the "Software"), to deal in the Software without
  11 ;;; restriction, including without limitation the rights to use, copy,
  12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  13 ;;; of the Software, and to permit persons to whom the Software is
  14 ;;; furnished to do so, subject to the following conditions:
  15 ;;;
  16 ;;; The above copyright notice and this permission notice shall be
  17 ;;; included in all copies or substantial portions of the Software.
  18 ;;;
  19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  22 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  26 ;;; DEALINGS IN THE SOFTWARE.
  27 ;;;
  28
  29 (in-package #:cffi-tests)
  30
  31 ;;;# Calling with Built-In C Types
  32 ;;;
  33 ;;; Tests calling standard C library functions both passing and
  34 ;;; returning each built-in type.
  35
  36 ;;; Don't run these tests if the implementation does not support
  37 ;;; foreign-funcall.
  38 #-cffi-sys::no-foreign-funcall
  39 (progn
  40
  41 (deftest funcall.char
  42     (foreign-funcall "toupper" :char (char-code #\a) :char)
  43   #.(char-code #\A))
  44
  45 (deftest funcall.int.1
  46     (foreign-funcall "abs" :int -100 :int)
  47   100)
  48
  49 (defun funcall-abs (n)
  50   (foreign-funcall "abs" :int n :int))
  51
  52 ;;; regression test: lispworks's %foreign-funcall based on creating
  53 ;;; and caching foreign-funcallables at macro-expansion time.
  54 (deftest funcall.int.2
  55     (funcall-abs -42)
  56   42)
  57
  58 (deftest funcall.long
  59     (foreign-funcall "labs" :long -131072 :long)
  60   131072)
  61
  62 #-cffi-sys::no-long-long
  63 (deftest funcall.long-long
  64     (foreign-funcall "my_llabs" :long-long -9223372036854775807 :long-long)
  65   9223372036854775807)
  66
  67 #-cffi-sys::no-long-long
  68 (deftest funcall.unsigned-long-long
  69     (let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
  70       (eql ullong-max
  71            (foreign-funcall "ullong" :unsigned-long-long ullong-max
  72                                      :unsigned-long-long)))
  73   t)
  74
  75 (deftest funcall.float
  76     (foreign-funcall "my_sqrtf" :float 16.0 :float)
  77   4.0)
  78
  79 (deftest funcall.double
  80     (foreign-funcall "sqrt" :double 36.0d0 :double)
  81   6.0d0)
  82
  83 #+(and scl long-float)
  84 (deftest funcall.long-double
  85     (foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
  86   6.0l0)
  87
  88 (deftest funcall.string.1
  89     (foreign-funcall "strlen" :string "Hello" :int)
  90   5)
  91
  92 (deftest funcall.string.2
  93     (with-foreign-pointer-as-string (s 100)
  94       (setf (mem-ref s :char) 0)
  95       (foreign-funcall "strcpy" :pointer s :string "Hello" :pointer)
  96       (foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
  97   "Hello, world!")
  98
  99 (deftest funcall.string.3
 100     (with-foreign-pointer (ptr 100)
 101       (lisp-string-to-foreign "Hello, " ptr 8)
 102       (foreign-funcall "strcat" :pointer ptr :string "world!" :string))
 103   "Hello, world!")
 104
 105 ;;;# Calling Varargs Functions
 106
 107 (deftest funcall.varargs.nostdlib
 108     (foreign-funcall-varargs
 109      "sum_double_arbitrary" (:int 26)
 110      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 111      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 112      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 113      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 114      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 115      :double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
 116      :double 3.14d0 :double 3.14d0
 117      :double)
 118   81.64d0)
 119
 120 ;; The CHAR argument must be passed as :INT because chars are promoted
 121 ;; to ints when passed as variable arguments.
 122 (deftest funcall.varargs.char
 123     (with-foreign-pointer-as-string (s 100)
 124       (setf (mem-ref s :char) 0)
 125       (foreign-funcall-varargs
 126        "sprintf" (:pointer s :string "%c") :int 65 :int))
 127   "A")
 128
 129 (deftest funcall.varargs.int
 130     (with-foreign-pointer-as-string (s 100)
 131       (setf (mem-ref s :char) 0)
 132       (foreign-funcall-varargs
 133        "sprintf" (:pointer s :string "%d") :int 1000 :int))
 134   "1000")
 135
 136 (deftest funcall.varargs.long
 137     (with-foreign-pointer-as-string (s 100)
 138       (setf (mem-ref s :char) 0)
 139       (foreign-funcall-varargs
 140        "sprintf" (:pointer s :string "%ld")
 141        :long 131072 :int))
 142   "131072")
 143
 144 ;;; There is no FUNCALL.VARARGS.FLOAT as floats are promoted to double
 145 ;;; when passed as variable arguments.  Currently this fails in SBCL
 146 ;;; and CMU CL on Darwin/ppc.
 147 (deftest funcall.varargs.double
 148     (with-foreign-pointer-as-string (s 100)
 149       (setf (mem-ref s :char) 0)
 150       (foreign-funcall-varargs
 151        "sprintf" (:pointer s :string "%.0f") :double (* pi 100d0) :int))
 152   "314")
 153
 154 #+(and scl long-float)
 155 (deftest funcall.varargs.long-double
 156     (with-foreign-pointer-as-string (s 100)
 157       (setf (mem-ref s :char) 0)
 158       (foreign-funcall-varargs
 159        "sprintf" :pointer s :string "%.0Lf" :long-double (* pi 100) :int))
 160   "314")
 161
 162 (deftest funcall.varargs.string
 163     (with-foreign-pointer-as-string (s 100)
 164       (setf (mem-ref s :char) 0)
 165       (foreign-funcall-varargs
 166        "sprintf" (:pointer s :string "%s, %s!") :string "Hello" :string "world" :int))
 167   "Hello, world!")
 168
 169 ;;; See DEFCFUN.DOUBLE26.
 170 (deftest funcall.double26
 171     (foreign-funcall "sum_double26"
 172                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 173                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 174                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 175                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 176                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 177                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 178                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 179                      :double 3.14d0 :double 3.14d0 :double 3.14d0
 180                      :double 3.14d0 :double 3.14d0 :double)
 181   81.64d0)
 182
 183 ;;; See DEFCFUN.FLOAT26.
 184 (deftest funcall.float26
 185     (foreign-funcall "sum_float26"
 186                      :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
 187                      :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
 188                      :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
 189                      :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
 190                      :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
 191                      :float 5.0 :float)
 192   130.0)
 193
 194 ;;; Funcalling a pointer.
 195 (deftest funcall.f-s-p.1
 196     (foreign-funcall-pointer (foreign-symbol-pointer "abs") nil :int -42 :int)
 197   42)
 198
 199 ;;;# Namespaces
 200
 201 #-cffi-sys::flat-namespace
 202 (deftest funcall.namespace.1
 203     (values (foreign-funcall ("ns_function" :library libtest) :boolean)
 204             (foreign-funcall ("ns_function" :library libtest2) :boolean))
 205   t nil)
 206
 207 ;;;# stdcall
 208
 209 #+(and x86 windows (not cffi-sys::no-stdcall))
 210 (deftest funcall.stdcall.1
 211     (flet ((fun ()
 212              (foreign-funcall ("stdcall_fun@12" :convention :stdcall)
 213                               :int 1 :int 2 :int 3 :int)))
 214       (loop repeat 100 do (fun)
 215             finally (return (fun))))
 216   6)
 217
 218 ;;; RT: NIL arguments are skipped
 219
 220 (defvar *nil-skipped*)
 221
 222 (define-foreign-type check-nil-skip-type ()
 223   ()
 224   (:actual-type :pointer)
 225   (:simple-parser check-nil-skip-type))
 226
 227 (defmethod expand-to-foreign (val (type check-nil-skip-type))
 228   (declare (ignore val))
 229   (setf *nil-skipped* nil)
 230   (null-pointer))
 231
 232 (deftest funcall.nil-skip
 233     (let ((*nil-skipped* t))
 234       (compile nil '(lambda ()
 235                      (foreign-funcall "abs" check-nil-skip-type nil)))
 236       *nil-skipped*)
 237   nil)
 238
 239 ;;; RT: CLISP returns NIL instead of a null-pointer
 240
 241 (deftest funcall.pointer-not-nil
 242     (not (null (foreign-funcall "strchr" :string "" :int 1 :pointer)))
 243   t)
 244
 245 ) ;; #-cffi-sys::no-foreign-funcall