funcall.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
funcall.lisp (8245B)
---
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 "%.2f") :double (coerce pi 'double-float) :int))
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 "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