GopherProxy

	tforeign-globals.lisp - clic - Clic is an command line interactive client for g…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tforeign-globals.lisp (9271B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; foreign-globals.lisp --- Tests on foreign globals.
	4 ;;;
	5 ;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira(@)common-lisp.net>
	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 (defcvar ("var_char" char-var) :char)
	31 (defcvar "var_unsigned_char" :unsigned-char)
	32 (defcvar "var_short" :short)
	33 (defcvar "var_unsigned_short" :unsigned-short)
	34 (defcvar "var_int" :int)
	35 (defcvar "var_unsigned_int" :unsigned-int)
	36 (defcvar "var_long" :long)
	37 (defcvar "var_unsigned_long" :unsigned-long)
	38 (defcvar "var_float" :float)
	39 (defcvar "var_double" :double)
	40 (defcvar "var_pointer" :pointer)
	41 (defcvar "var_string" :string)
	42 (defcvar "var_long_long" :long-long)
	43 (defcvar "var_unsigned_long_long" :unsigned-long-long)
	44
	45 ;;; The expected failures marked below result from this odd behaviour:
	46 ;;;
	47 ;;; (foreign-symbol-pointer "var_char") => NIL
	48 ;;;
	49 ;;; (foreign-symbol-pointer "var_char" :library 'libtest)
	50 ;;; => #<Pointer to type :VOID = #xF7F50740>
	51 ;;;
	52 ;;; Why is this happening? --luis
	53 #+lispworks
	54 (mapc (lambda (x) (pushnew x rtest::expected-failures))
	55 '(foreign-globals.ref.char foreign-globals.get-var-pointer.1
	56 foreign-globals.get-var-pointer.2 foreign-globals.symbol-name
	57 foreign-globals.read-only.1 ))
	58
	59 (deftest foreign-globals.ref.char
	60 char-var
	61 -127)
	62
	63 (deftest foreign-globals.ref.unsigned-char
	64 var-unsigned-char
	65 255)
	66
	67 (deftest foreign-globals.ref.short
	68 var-short
	69 -32767)
	70
	71 (deftest foreign-globals.ref.unsigned-short
	72 var-unsigned-short
	73 65535)
	74
	75 (deftest foreign-globals.ref.int
	76 var-int
	77 -32767)
	78
	79 (deftest foreign-globals.ref.unsigned-int
	80 var-unsigned-int
	81 65535)
	82
	83 (deftest foreign-globals.ref.long
	84 var-long
	85 -2147483647)
	86
	87 (deftest foreign-globals.ref.unsigned-long
	88 var-unsigned-long
	89 4294967295)
	90
	91 (deftest foreign-globals.ref.float
	92 var-float
	93 42.0)
	94
	95 (deftest foreign-globals.ref.double
	96 var-double
	97 42.0d0)
	98
	99 (deftest foreign-globals.ref.pointer
	100 (null-pointer-p var-pointer)
	101 t)
	102
	103 (deftest foreign-globals.ref.string
	104 var-string
	105 "Hello, foreign world!")
	106
	107 #+openmcl (push 'foreign-globals.set.long-long rt::expected-failures)
	108
	109 (deftest foreign-globals.ref.long-long
	110 var-long-long
	111 -9223372036854775807)
	112
	113 (deftest foreign-globals.ref.unsigned-long-long
	114 var-unsigned-long-long
	115 18446744073709551615)
	116
	117 ;; The .set. tests restore the old values so that the .ref.
	118 ;; don't fail when re-run.
	119 (defmacro with-old-value-restored ((place) &body body)
	120 (let ((old (gensym)))
	121 `(let ((,old ,place))
	122 (prog1
	123 (progn ,@body)
	124 (setq ,place ,old)))))
	125
	126 (deftest foreign-globals.set.int
	127 (with-old-value-restored (var-int)
	128 (setq var-int 42)
	129 var-int)
	130 42)
	131
	132 (deftest foreign-globals.set.string
	133 (with-old-value-restored (var-string)
	134 (setq var-string "Ehxosxangxo")
	135 (prog1
	136 var-string
	137 ;; free the string we just allocated
	138 (foreign-free (mem-ref (get-var-pointer 'var-string) :pointer)…
	139 "Ehxosxangxo")
	140
	141 (deftest foreign-globals.set.long-long
	142 (with-old-value-restored (var-long-long)
	143 (setq var-long-long -9223000000000005808)
	144 var-long-long)
	145 -9223000000000005808)
	146
	147 (deftest foreign-globals.get-var-pointer.1
	148 (pointerp (get-var-pointer 'char-var))
	149 t)
	150
	151 (deftest foreign-globals.get-var-pointer.2
	152 (mem-ref (get-var-pointer 'char-var) :char)
	153 -127)
	154
	155 ;;; Symbol case.
	156
	157 (defcvar "UPPERCASEINT1" :int)
	158 (defcvar "UPPER_CASE_INT1" :int)
	159 (defcvar "MiXeDCaSeInT1" :int)
	160 (defcvar "MiXeD_CaSe_InT1" :int)
	161
	162 (deftest foreign-globals.ref.uppercaseint1
	163 uppercaseint1
	164 12345)
	165
	166 (deftest foreign-globals.ref.upper-case-int1
	167 upper-case-int1
	168 23456)
	169
	170 (deftest foreign-globals.ref.mixedcaseint1
	171 mixedcaseint1
	172 34567)
	173
	174 (deftest foreign-globals.ref.mixed-case-int1
	175 mixed-case-int1
	176 45678)
	177
	178 (when (string= (symbol-name 'nil) "NIL")
	179 (let ((readtable (copy-readtable)))
	180 (setf (readtable-case readtable) :invert)
	181 (eval (read-from-string "(defcvar \"UPPERCASEINT2\" :int)"))
	182 (eval (read-from-string "(defcvar \"UPPER_CASE_INT2\" :int)"))
	183 (eval (read-from-string "(defcvar \"MiXeDCaSeInT2\" :int)"))
	184 (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\" :int)"))
	185 (setf (readtable-case readtable) :preserve)
	186 (eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\" :INT)"))
	187 (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\" :INT)"))
	188 (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\" :INT)"))
	189 (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\" :INT)"))))
	190
	191
	192 ;;; EVAL gets rid of SBCL's unreachable code warnings.
	193 (when (string= (symbol-name (eval nil)) "nil")
	194 (let ((readtable (copy-readtable)))
	195 (setf (readtable-case readtable) :invert)
	196 (eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\" :INT)"))
	197 (eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\" :INT)"))
	198 (eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\" :INT)"))
	199 (eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\" :INT)"))
	200 (setf (readtable-case readtable) :downcase)
	201 (eval (read-from-string "(defcvar \"UPPERCASEINT3\" :int)"))
	202 (eval (read-from-string "(defcvar \"UPPER_CASE_INT3\" :int)"))
	203 (eval (read-from-string "(defcvar \"MiXeDCaSeInT3\" :int)"))
	204 (eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\" :int)"))))
	205
	206 (deftest foreign-globals.ref.uppercaseint2
	207 uppercaseint2
	208 12345)
	209
	210 (deftest foreign-globals.ref.upper-case-int2
	211 upper-case-int2
	212 23456)
	213
	214 (deftest foreign-globals.ref.mixedcaseint2
	215 mixedcaseint2
	216 34567)
	217
	218 (deftest foreign-globals.ref.mixed-case-int2
	219 mixed-case-int2
	220 45678)
	221
	222 (deftest foreign-globals.ref.uppercaseint3
	223 uppercaseint3
	224 12345)
	225
	226 (deftest foreign-globals.ref.upper-case-int3
	227 upper-case-int3
	228 23456)
	229
	230 (deftest foreign-globals.ref.mixedcaseint3
	231 mixedcaseint3
	232 34567)
	233
	234 (deftest foreign-globals.ref.mixed-case-int3
	235 mixed-case-int3
	236 45678)
	237
	238 ;;; regression test:
	239 ;;; gracefully accept symbols in defcvar
	240
	241 (defcvar var-char :char)
	242 (defcvar var-char :char)
	243
	244 (deftest foreign-globals.symbol-name
	245 (values var-char var-char)
	246 -127 -127)
	247
	248 ;;;# Namespace
	249
	250 #-cffi-sys::flat-namespace
	251 (progn
	252 (deftest foreign-globals.namespace.1
	253 (values
	254 (mem-ref (foreign-symbol-pointer "var_char" :library 'libtest) :c…
	255 (foreign-symbol-pointer "var_char" :library 'libtest2))
	256 -127 nil)
	257
	258 (deftest foreign-globals.namespace.2
	259 (values
	260 (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest) :boo…
	261 (mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :bo…
	262 t nil)
	263
	264 ;; For its "default" module, Lispworks seems to cache lookups from
	265 ;; the newest module tried. If a lookup happens to have failed
	266 ;; subsequent lookups will fail even the symbol exists in other
	267 ;; modules. So this test fails.
	268 #+lispworks
	269 (pushnew 'foreign-globals.namespace.3 regression-test::*expected-failu…
	270
	271 (deftest foreign-globals.namespace.3
	272 (values
	273 (foreign-symbol-pointer "var_char" :library 'libtest2)
	274 (mem-ref (foreign-symbol-pointer "var_char") :char))
	275 nil -127)
	276
	277 (defcvar ("ns_var" ns-var1 :library libtest) :boolean)
	278 (defcvar ("ns_var" ns-var2 :library libtest2) :boolean)
	279
	280 (deftest foreign-globals.namespace.4
	281 (values ns-var1 ns-var2)
	282 t nil))
	283
	284 ;;;# Read-only
	285
	286 (defcvar ("var_char" var-char-ro :read-only t) :char
	287 "docstring")
	288
	289 (deftest foreign-globals.read-only.1
	290 (values var-char-ro
	291 (ignore-errors (setf var-char-ro 12)))
	292 -127 nil)
	293
	294 (deftest defcvar.docstring
	295 (documentation 'var-char-ro 'variable)
	296 "docstring")
	297
	298 ;;;# Other tests
	299
	300 ;;; RT: FOREIGN-SYMBOL-POINTER shouldn't signal an error when passed
	301 ;;; an undefined variable.
	302 (deftest foreign-globals.undefined.1
	303 (foreign-symbol-pointer "surely-undefined?")
	304 nil)
	305
	306 (deftest foreign-globals.error.1
	307 (handler-case (foreign-symbol-pointer 'not-a-string)
	308 (type-error () t))
	309 t)