Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

310 lines (251 sloc) 9.271 kB
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; foreign-globals.lisp --- Tests on foreign globals.
;;;
;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(in-package #:cffi-tests)
(defcvar ("var_char" *char-var*) :char)
(defcvar "var_unsigned_char" :unsigned-char)
(defcvar "var_short" :short)
(defcvar "var_unsigned_short" :unsigned-short)
(defcvar "var_int" :int)
(defcvar "var_unsigned_int" :unsigned-int)
(defcvar "var_long" :long)
(defcvar "var_unsigned_long" :unsigned-long)
(defcvar "var_float" :float)
(defcvar "var_double" :double)
(defcvar "var_pointer" :pointer)
(defcvar "var_string" :string)
(defcvar "var_long_long" :long-long)
(defcvar "var_unsigned_long_long" :unsigned-long-long)
;;; The expected failures marked below result from this odd behaviour:
;;;
;;; (foreign-symbol-pointer "var_char") => NIL
;;;
;;; (foreign-symbol-pointer "var_char" :library 'libtest)
;;; => #<Pointer to type :VOID = #xF7F50740>
;;;
;;; Why is this happening? --luis
#+lispworks
(mapc (lambda (x) (pushnew x rtest::*expected-failures*))
'(foreign-globals.ref.char foreign-globals.get-var-pointer.1
foreign-globals.get-var-pointer.2 foreign-globals.symbol-name
foreign-globals.read-only.1 ))
(deftest foreign-globals.ref.char
*char-var*
-127)
(deftest foreign-globals.ref.unsigned-char
*var-unsigned-char*
255)
(deftest foreign-globals.ref.short
*var-short*
-32767)
(deftest foreign-globals.ref.unsigned-short
*var-unsigned-short*
65535)
(deftest foreign-globals.ref.int
*var-int*
-32767)
(deftest foreign-globals.ref.unsigned-int
*var-unsigned-int*
65535)
(deftest foreign-globals.ref.long
*var-long*
-2147483647)
(deftest foreign-globals.ref.unsigned-long
*var-unsigned-long*
4294967295)
(deftest foreign-globals.ref.float
*var-float*
42.0)
(deftest foreign-globals.ref.double
*var-double*
42.0d0)
(deftest foreign-globals.ref.pointer
(null-pointer-p *var-pointer*)
t)
(deftest foreign-globals.ref.string
*var-string*
"Hello, foreign world!")
#+openmcl (push 'foreign-globals.set.long-long rt::*expected-failures*)
(deftest foreign-globals.ref.long-long
*var-long-long*
-9223372036854775807)
(deftest foreign-globals.ref.unsigned-long-long
*var-unsigned-long-long*
18446744073709551615)
;; The *.set.* tests restore the old values so that the *.ref.*
;; don't fail when re-run.
(defmacro with-old-value-restored ((place) &body body)
(let ((old (gensym)))
`(let ((,old ,place))
(prog1
(progn ,@body)
(setq ,place ,old)))))
(deftest foreign-globals.set.int
(with-old-value-restored (*var-int*)
(setq *var-int* 42)
*var-int*)
42)
(deftest foreign-globals.set.string
(with-old-value-restored (*var-string*)
(setq *var-string* "Ehxosxangxo")
(prog1
*var-string*
;; free the string we just allocated
(foreign-free (mem-ref (get-var-pointer '*var-string*) :pointer))))
"Ehxosxangxo")
(deftest foreign-globals.set.long-long
(with-old-value-restored (*var-long-long*)
(setq *var-long-long* -9223000000000005808)
*var-long-long*)
-9223000000000005808)
(deftest foreign-globals.get-var-pointer.1
(pointerp (get-var-pointer '*char-var*))
t)
(deftest foreign-globals.get-var-pointer.2
(mem-ref (get-var-pointer '*char-var*) :char)
-127)
;;; Symbol case.
(defcvar "UPPERCASEINT1" :int)
(defcvar "UPPER_CASE_INT1" :int)
(defcvar "MiXeDCaSeInT1" :int)
(defcvar "MiXeD_CaSe_InT1" :int)
(deftest foreign-globals.ref.uppercaseint1
*uppercaseint1*
12345)
(deftest foreign-globals.ref.upper-case-int1
*upper-case-int1*
23456)
(deftest foreign-globals.ref.mixedcaseint1
*mixedcaseint1*
34567)
(deftest foreign-globals.ref.mixed-case-int1
*mixed-case-int1*
45678)
(when (string= (symbol-name 'nil) "NIL")
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) :invert)
(eval (read-from-string "(defcvar \"UPPERCASEINT2\" :int)"))
(eval (read-from-string "(defcvar \"UPPER_CASE_INT2\" :int)"))
(eval (read-from-string "(defcvar \"MiXeDCaSeInT2\" :int)"))
(eval (read-from-string "(defcvar \"MiXeD_CaSe_InT2\" :int)"))
(setf (readtable-case *readtable*) :preserve)
(eval (read-from-string "(DEFCVAR \"UPPERCASEINT3\" :INT)"))
(eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT3\" :INT)"))
(eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT3\" :INT)"))
(eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT3\" :INT)"))))
;;; EVAL gets rid of SBCL's unreachable code warnings.
(when (string= (symbol-name (eval nil)) "nil")
(let ((*readtable* (copy-readtable)))
(setf (readtable-case *readtable*) :invert)
(eval (read-from-string "(DEFCVAR \"UPPERCASEINT2\" :INT)"))
(eval (read-from-string "(DEFCVAR \"UPPER_CASE_INT2\" :INT)"))
(eval (read-from-string "(DEFCVAR \"MiXeDCaSeInT2\" :INT)"))
(eval (read-from-string "(DEFCVAR \"MiXeD_CaSe_InT2\" :INT)"))
(setf (readtable-case *readtable*) :downcase)
(eval (read-from-string "(defcvar \"UPPERCASEINT3\" :int)"))
(eval (read-from-string "(defcvar \"UPPER_CASE_INT3\" :int)"))
(eval (read-from-string "(defcvar \"MiXeDCaSeInT3\" :int)"))
(eval (read-from-string "(defcvar \"MiXeD_CaSe_InT3\" :int)"))))
(deftest foreign-globals.ref.uppercaseint2
*uppercaseint2*
12345)
(deftest foreign-globals.ref.upper-case-int2
*upper-case-int2*
23456)
(deftest foreign-globals.ref.mixedcaseint2
*mixedcaseint2*
34567)
(deftest foreign-globals.ref.mixed-case-int2
*mixed-case-int2*
45678)
(deftest foreign-globals.ref.uppercaseint3
*uppercaseint3*
12345)
(deftest foreign-globals.ref.upper-case-int3
*upper-case-int3*
23456)
(deftest foreign-globals.ref.mixedcaseint3
*mixedcaseint3*
34567)
(deftest foreign-globals.ref.mixed-case-int3
*mixed-case-int3*
45678)
;;; regression test:
;;; gracefully accept symbols in defcvar
(defcvar *var-char* :char)
(defcvar var-char :char)
(deftest foreign-globals.symbol-name
(values *var-char* var-char)
-127 -127)
;;;# Namespace
#-cffi-sys::flat-namespace
(progn
(deftest foreign-globals.namespace.1
(values
(mem-ref (foreign-symbol-pointer "var_char" :library 'libtest) :char)
(foreign-symbol-pointer "var_char" :library 'libtest2))
-127 nil)
(deftest foreign-globals.namespace.2
(values
(mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest) :boolean)
(mem-ref (foreign-symbol-pointer "ns_var" :library 'libtest2) :boolean))
t nil)
;; For its "default" module, Lispworks seems to cache lookups from
;; the newest module tried. If a lookup happens to have failed
;; subsequent lookups will fail even the symbol exists in other
;; modules. So this test fails.
#+lispworks
(pushnew 'foreign-globals.namespace.3 regression-test::*expected-failures*)
(deftest foreign-globals.namespace.3
(values
(foreign-symbol-pointer "var_char" :library 'libtest2)
(mem-ref (foreign-symbol-pointer "var_char") :char))
nil -127)
(defcvar ("ns_var" *ns-var1* :library libtest) :boolean)
(defcvar ("ns_var" *ns-var2* :library libtest2) :boolean)
(deftest foreign-globals.namespace.4
(values *ns-var1* *ns-var2*)
t nil))
;;;# Read-only
(defcvar ("var_char" *var-char-ro* :read-only t) :char
"docstring")
(deftest foreign-globals.read-only.1
(values *var-char-ro*
(ignore-errors (setf *var-char-ro* 12)))
-127 nil)
(deftest defcvar.docstring
(documentation '*var-char-ro* 'variable)
"docstring")
;;;# Other tests
;;; RT: FOREIGN-SYMBOL-POINTER shouldn't signal an error when passed
;;; an undefined variable.
(deftest foreign-globals.undefined.1
(foreign-symbol-pointer "surely-undefined?")
nil)
(deftest foreign-globals.error.1
(handler-case (foreign-symbol-pointer 'not-a-string)
(type-error () t))
t)
Jump to Line
Something went wrong with that request. Please try again.