GopherProxy

	tfsbv.lisp - clic - Clic is an command line interactive client for gopher writt…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tfsbv.lisp (5358B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; fsbv.lisp --- Tests of foreign structure by value calls.
	4 ;;;
	5 ;;; Copyright (C) 2011, Liam M. Healy
	6 ;;;
	7 ;;; Permission is hereby granted, free of charge, to any person
	8 ;;; obtaining a copy of this software and associated documentation
	9 ;;; files (the "Software"), to deal in the Software without
	10 ;;; restriction, including without limitation the rights to use, copy,
	11 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
	12 ;;; of the Software, and to permit persons to whom the Software is
	13 ;;; furnished to do so, subject to the following conditions:
	14 ;;;
	15 ;;; The above copyright notice and this permission notice shall be
	16 ;;; included in all copies or substantial portions of the Software.
	17 ;;;
	18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
	19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
	20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
	21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
	22 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
	23 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
	24 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
	25 ;;; DEALINGS IN THE SOFTWARE.
	26 ;;;
	27
	28 (in-package #:cffi-tests)
	29
	30 ;; Requires struct.lisp
	31
	32 (defcfun "sumpair" :int
	33 (p (:struct struct-pair)))
	34
	35 (defcfun "makepair" (:struct struct-pair)
	36 (condition :bool))
	37
	38 (defcfun "doublepair" (:struct struct-pair)
	39 (p (:struct struct-pair)))
	40
	41 (defcfun "prodsumpair" :double
	42 (p (:struct struct-pair+double)))
	43
	44 (defcfun "doublepairdouble" (:struct struct-pair+double)
	45 (p (:struct struct-pair+double)))
	46
	47 ;;; Call struct by value
	48 (deftest fsbv.1
	49 (sumpair '(1 . 2))
	50 3)
	51
	52 ;;; See lp#1528719
	53 (deftest (fsbv.wfo :expected-to-fail t)
	54 (with-foreign-object (arg '(:struct struct-pair))
	55 (convert-into-foreign-memory '(40 . 2) '(:struct struct-pair) arg)
	56 (sumpair arg))
	57 42)
	58
	59 ;;; Call and return struct by value
	60 (deftest fsbv.2
	61 (doublepair '(1 . 2))
	62 (2 . 4))
	63
	64 ;;; return struct by value
	65 (deftest (fsbv.makepair.1 :expected-to-fail t)
	66 (makepair nil)
	67 (-127 . 43))
	68
	69 (deftest (fsbv.makepair.2 :expected-to-fail t)
	70 (makepair t)
	71 (-127 . 42))
	72
	73 ;;; Call recursive structure by value
	74 (deftest fsbv.3
	75 (prodsumpair '(pr (a 4 b 5) dbl 2.5d0))
	76 22.5d0)
	77
	78 ;;; Call and return recursive structure by value
	79 (deftest fsbv.4
	80 (let ((ans (doublepairdouble '(pr (a 4 b 5) dbl 2.5d0))))
	81 (values (getf (getf ans 'pr) 'a)
	82 (getf (getf ans 'pr) 'b)
	83 (getf ans 'dbl)))
	84 8
	85 10
	86 5.0d0)
	87
	88 (defcstruct (struct-with-array :size 6)
	89 (s1 (:array :char 6)))
	90
	91 (defcfun "zork" :void
	92 (p (:struct struct-with-array)))
	93
	94 ;;; Typedef fsbv test
	95
	96 (defcfun ("sumpair" sumpair2) :int
	97 (p struct-pair-typedef1))
	98
	99 (deftest fsbv.5
	100 (sumpair2 '(1 . 2))
	101 3)
	102
	103 (defcfun "returnpairpointer" (:pointer (:struct struct-pair))
	104 (ignored (:struct struct-pair)))
	105
	106 (deftest fsbv.return-a-pointer
	107 (let ((ptr (returnpairpointer '(1 . 2))))
	108 (+ (foreign-slot-value ptr '(:struct struct-pair) 'a)
	109 (foreign-slot-value ptr '(:struct struct-pair) 'b)))
	110 42)
	111
	112 ;;; Test ulonglong on no-long-long implementations.
	113
	114 (defcfun "ullsum" :unsigned-long-long
	115 (a :unsigned-long-long) (b :unsigned-long-long))
	116
	117 (deftest fsbv.6
	118 (ullsum #x10DEADBEEF #x2300000000)
	119 #x33DEADBEEF)
	120
	121 ;;; Combine structures by value with a string argument
	122 (defcfun "stringlenpair" (:struct struct-pair)
	123 (s :string)
	124 (p (:struct struct-pair)))
	125
	126 (deftest fsbv.7
	127 (stringlenpair "abc" '(1 . 2))
	128 (3 . 6))
	129
	130 ;;; Combine structures by value with an enum argument
	131 (defcfun "enumpair" (:int)
	132 (e numeros)
	133 (p (:struct struct-pair)))
	134
	135 (deftest fsbv.8
	136 (enumpair :two '(1 . 2))
	137 5)
	138
	139 ;;; returning struct with bitfield member (bug #1474631)
	140 (defbitfield (struct-bitfield :unsigned-int)
	141 (:a 1)
	142 (:b 2))
	143
	144 (defcstruct bitfield-struct
	145 (b struct-bitfield))
	146
	147 (defcfun "structbitfield" (:struct bitfield-struct)
	148 (x :unsigned-int))
	149
	150 (defctype struct-bitfield-typedef struct-bitfield)
	151
	152 (defcstruct bitfield-struct.2
	153 (b struct-bitfield-typedef))
	154
	155 (defcfun ("structbitfield" structbitfield.2) (:struct bitfield-struct.2)
	156 (x :unsigned-int))
	157
	158 ;; these would get stuck in an infinite loop previously
	159 (deftest fsbv.struct-bitfield.0
	160 (structbitfield 0)
	161 (b nil))
	162
	163 (deftest fsbv.struct-bitfield.1
	164 (structbitfield 1)
	165 (b (:a)))
	166
	167 (deftest fsbv.struct-bitfield.2
	168 (structbitfield 2)
	169 (b (:b)))
	170
	171 (deftest fsbv.struct-bitfield.3
	172 (structbitfield.2 2)
	173 (b (:b)))
	174
	175 ;;; Test for a discrepancy between normal and fsbv return values
	176 (cffi:define-foreign-type int-return-code (cffi::foreign-type-alias)
	177 ()
	178 (:default-initargs :actual-type (cffi::parse-type :int))
	179 (:simple-parser int-return-code))
	180
	181 (defmethod cffi:expand-from-foreign (value (type int-return-code))
	182 ;; NOTE: strictly speaking it should be
	183 ;; (cffi:convert-from-foreign ,value :int), but it's irrelevant in thi…
	184 `(let ((return-code ,value))
	185 (check-type return-code integer)
	186 return-code))
	187
	188 (defcfun (noargs-with-typedef "noargs") int-return-code)
	189
	190 (deftest fsbv.noargs-with-typedef ; for reference, not an FSBV call
	191 (noargs-with-typedef)
	192 42)
	193
	194 (defcfun (sumpair-with-typedef "sumpair") int-return-code
	195 (p (:struct struct-pair)))
	196
	197 (deftest (fsbv.return-value-typedef)
	198 (sumpair-with-typedef '(40 . 2))
	199 42)