GopherProxy

	tfuncall.lisp - clic - Clic is an command line interactive client for gopher wr…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tfuncall.lisp (8245B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; funcall.lisp --- Tests function calling.
	4 ;;;
	5 ;;; Copyright (C) 2005-2006, James Bielman <[email protected]>
	6 ;;; Copyright (C) 2005-2007, Luis Oliveira <[email protected]>
	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-lo…
	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…
	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 "%.2f") :double (coerce pi 'double-…
	152 "3.14")
	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 "%.2Lf" :long-double pi :int))
	160 "3.14")
	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 …
	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 …
	187 :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float …
	188 :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float …
	189 :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float …
	190 :float 5.0 :float 5.0 :float 5.0 :float 5.0 :float …
	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…
	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