funcall.lisp - clic - Clic is an command line interactive client for gopher wri… | |
git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65… | |
Log | |
Files | |
Refs | |
Tags | |
README | |
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 <[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 |