ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tmux etc

Browse source
This commit is contained in:
Ian Keane 2020-02-18 14:21:14 -05:00
parent 276853ba84
commit 1cb167b597
361 changed files with 77302 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

98
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/GNUmakefile Normal file
View file

@ -0,0 +1,98 @@
# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*-
#
# Makefile --- Make targets for various tasks.
#
# Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
#
# 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.
#
OSTYPE = $(shell uname)
ARCH = $(shell uname -m)
CC := gcc
CFLAGS := -Wall -std=c99 -pedantic
SHLIB_CFLAGS := -shared
SHLIB_EXT := .so
ifneq ($(if $(filter Linux %BSD,$(OSTYPE)),OK), OK)
ifeq ($(OSTYPE), Darwin)
SHLIB_CFLAGS := -dynamiclib
SHLIB_EXT := .dylib
ifeq ($(shell sysctl -n hw.optional.x86_64), 1)
ARCH := x86_64
CFLAGS_64 := -m64
endif
else
ifeq ($(OSTYPE), SunOS)
CFLAGS := -m64 -fPIC -c -Wall -std=c99 -pedantic
else
# Let's assume this is win32
SHLIB_EXT := .dll
endif
endif
endif
ifneq ($(ARCH), x86_64)
CFLAGS += -lm
endif
ifeq ($(ARCH), x86_64)
CFLAGS_64 += -fPIC
endif
# Are all G5s ppc970s?
ifeq ($(ARCH), ppc970)
CFLAGS_64 += -m64
endif
SHLIBS = libtest$(SHLIB_EXT) libtest2$(SHLIB_EXT) libfsbv$(SHLIB_EXT)
ifeq ($(ARCH), x86_64)
SHLIBS += libtest32$(SHLIB_EXT) libtest2_32$(SHLIB_EXT) libfsbv_32$(SHLIB_EXT)
endif
shlibs: $(SHLIBS)
libtest$(SHLIB_EXT): libtest.c
$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<
libtest2$(SHLIB_EXT): libtest2.c
$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<
libfsbv$(SHLIB_EXT): libfsbv.c
$(CC) -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $(CFLAGS_64) $<
ifeq ($(ARCH), x86_64)
libtest32$(SHLIB_EXT): libtest.c
-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
libtest2_32$(SHLIB_EXT): libtest2.c
-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
libfsbv_32$(SHLIB_EXT): libfsbv.c
-$(CC) -m32 -o $@ $(SHLIB_CFLAGS) $(CFLAGS) $<
endif
clean:
rm -f *.so *.dylib *.dll *.bundle
# vim: ft=make ts=3 noet

2
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/Makefile Normal file
View file

@ -0,0 +1,2 @@
shlibs clean:
gmake $@

71
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/arrays.lisp Normal file
View file

@ -0,0 +1,71 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; arrays.lisp --- Tests for foreign arrays.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; 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.
;;;
;;;#Foreign Array Conversion Tests
;;;
(in-package #:cffi-tests)
(deftest array.foreign-to-lisp.basic
(with-foreign-array (ptr #(1 2 3 4 5) '(:array :int32 5))
(foreign-array-to-lisp ptr '(:array :int32 5)))
#(1 2 3 4 5))
(deftest array.foreign-to-lisp.adjustable
(with-foreign-array (ptr #(1 2 3 4 5) '(:array :int32 5))
(let ((array (foreign-array-to-lisp ptr '(:array :int32 5)
:adjustable t)))
(adjustable-array-p array)))
t)
(deftest array.foreign-to-lisp.displaced
(let ((array (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 0))))
(with-foreign-array (ptr #(10 20 30 40 50) '(:array :int32 5))
(let ((displaced (foreign-array-to-lisp ptr '(:array :int32 5)
:displaced-to array
:displaced-index-offset 5)))
array)))
#(1 2 3 4 5 10 20 30 40 50))
;;; Implementation detail: 15.1.2.2 of the CL standard states that the only
;;; truly portable array specializations are for bits (bit-vectors) and
;;; characters (strings). Since char-codes are implementation-dependent, it
;;; would be tricky to write a portable test for them without generating
;;; characters at runtime. So, for a truly portable test, we are only left with
;;; bits, which are luckily numeric, and equal to (UNSIGNED-BYTE 1).
;;; This is why the below test is so terribly wasteful, spending a whole byte
;;; for a single bit - CFFI has no capabilities for dealing with single bits,
;;; and this test is only meant to check correctness of the :ELEMENT-TYPE
;;; argument to MAKE-ARRAY. In actual use cases of specialized
;;; FOREIGN-ARRAY-TO-LISP, capable implementations will be able to make
;;; specialized arrays of types that are commonly optimized for and/or
;;; representable in hardware, such as (UNSIGNED-BYTE 8) on x86 architectures.
(deftest array.foreign-to-lisp.specialized
(with-foreign-array (ptr #(1 0 1 0 1 1 1 0) '(:array :int8 8))
(foreign-array-to-lisp ptr '(:array :int8 8) :element-type 'bit))
#*10101110)

148
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/bindings.lisp Normal file
View file

@ -0,0 +1,148 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; libtest.lisp --- Setup CFFI bindings for libtest.
;;;
;;; 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)
(define-foreign-library (libtest :type :test)
(:darwin (:or "libtest.dylib" "libtest32.dylib"))
(:unix (:or "libtest.so" "libtest32.so"))
(:windows "libtest.dll")
(t (:default "libtest")))
(define-foreign-library (libtest2 :type :test)
(:darwin (:or "libtest2.dylib" "libtest2_32.dylib"))
(:unix (:or "libtest2.so" "libtest2_32.so"))
(t (:default "libtest2")))
(define-foreign-library (libfsbv :type :test)
(:darwin (:or "libfsbv.dylib" "libfsbv32.dylib"))
(:unix (:or "libfsbv.so" "libfsbv_32.so"))
(:windows "libfsbv.dll")
(t (:default "libfsbv")))
(define-foreign-library libc
(:windows "msvcrt.dll"))
(define-foreign-library libm
#+(and lispworks darwin) ; not sure why the full path is necessary
(:darwin "/usr/lib/libm.dylib")
(t (:default "libm")))
(defmacro deftest (name &rest body)
(destructuring-bind (name &key expected-to-fail)
(alexandria:ensure-list name)
(let ((result `(rt:deftest ,name ,@body)))
(when expected-to-fail
(setf result `(progn
(when ,expected-to-fail
(pushnew ',name rt::*expected-failures*))
,result)))
result)))
(defun call-within-new-thread (fn &rest args)
(let (result
error
(cv (bordeaux-threads:make-condition-variable))
(lock (bordeaux-threads:make-lock)))
(bordeaux-threads:with-lock-held (lock)
(bordeaux-threads:make-thread
(lambda ()
(multiple-value-setq (result error)
(ignore-errors (apply fn args)))
(bordeaux-threads:with-lock-held (lock)
(bordeaux-threads:condition-notify cv))))
(bordeaux-threads:condition-wait cv lock)
(values result error))))
;;; As of OSX 10.6.6, loading CoreFoundation on something other than
;;; the initial thread results in a crash.
(deftest load-core-foundation
(progn
#+bordeaux-threads
(call-within-new-thread 'load-foreign-library
'(:framework "CoreFoundation"))
t)
t)
;;; Return the directory containing the source when compiling or
;;; loading this file. We don't use *LOAD-TRUENAME* because the fasl
;;; file may be in a different directory than the source with certain
;;; ASDF extensions loaded.
(defun load-directory ()
(let ((here #.(or *compile-file-truename* *load-truename*)))
(make-pathname :name nil :type nil :version nil
:defaults here)))
(defun load-test-libraries ()
(let ((*foreign-library-directories* (list (load-directory))))
(load-foreign-library 'libtest)
(load-foreign-library 'libtest2)
(load-foreign-library 'libfsbv)
(load-foreign-library 'libc)
#+(or abcl lispworks) (load-foreign-library 'libm)))
#-(:and :ecl (:not :dffi))
(load-test-libraries)
#+(:and :ecl (:not :dffi))
(ffi:load-foreign-library
#.(make-pathname :name "libtest" :type "so"
:defaults (or *compile-file-truename* *load-truename*)))
;;; check libtest version
(defparameter *required-dll-version* "20120107")
(defcvar "dll_version" :string)
(unless (string= *dll-version* *required-dll-version*)
(error "version check failed: expected ~s but libtest reports ~s"
*required-dll-version*
*dll-version*))
;;; The maximum and minimum values for single and double precision C
;;; floating point values, which may be quite different from the
;;; corresponding Lisp versions.
(defcvar "float_max" :float)
(defcvar "float_min" :float)
(defcvar "double_max" :double)
(defcvar "double_min" :double)
(defun run-cffi-tests (&key (compiled nil))
(let ((regression-test::*compile-tests* compiled)
(*package* (find-package '#:cffi-tests)))
(format t "~&;;; running tests (~Acompiled)" (if compiled "" "un"))
(do-tests)
(set-difference (regression-test:pending-tests)
regression-test::*expected-failures*)))
(defun run-all-cffi-tests ()
(append (run-cffi-tests :compiled nil)
(run-cffi-tests :compiled t)))
(defmacro expecting-error (&body body)
`(handler-case (progn ,@body :no-error)
(error () :error)))

526
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/callbacks.lisp Normal file
View file

@ -0,0 +1,526 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; callbacks.lisp --- Tests on callbacks.
;;;
;;; Copyright (C) 2005-2006, 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)
(defcfun "expect_char_sum" :int (f :pointer))
(defcfun "expect_unsigned_char_sum" :int (f :pointer))
(defcfun "expect_short_sum" :int (f :pointer))
(defcfun "expect_unsigned_short_sum" :int (f :pointer))
(defcfun "expect_int_sum" :int (f :pointer))
(defcfun "expect_unsigned_int_sum" :int (f :pointer))
(defcfun "expect_long_sum" :int (f :pointer))
(defcfun "expect_unsigned_long_sum" :int (f :pointer))
(defcfun "expect_float_sum" :int (f :pointer))
(defcfun "expect_double_sum" :int (f :pointer))
(defcfun "expect_pointer_sum" :int (f :pointer))
(defcfun "expect_strcat" :int (f :pointer))
#-cffi-sys::no-long-long
(progn
(defcfun "expect_long_long_sum" :int (f :pointer))
(defcfun "expect_unsigned_long_long_sum" :int (f :pointer)))
#+(and scl long-float)
(defcfun "expect_long_double_sum" :int (f :pointer))
(defcallback sum-char :char ((a :char) (b :char))
"Test if the named block is present and the docstring too."
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(return-from sum-char (+ a b)))
(defcallback sum-unsigned-char :unsigned-char
((a :unsigned-char) (b :unsigned-char))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-short :short ((a :short) (b :short))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-unsigned-short :unsigned-short
((a :unsigned-short) (b :unsigned-short))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-int :int ((a :int) (b :int))
(+ a b))
(defcallback sum-unsigned-int :unsigned-int
((a :unsigned-int) (b :unsigned-int))
(+ a b))
(defcallback sum-long :long ((a :long) (b :long))
(+ a b))
(defcallback sum-unsigned-long :unsigned-long
((a :unsigned-long) (b :unsigned-long))
(+ a b))
#-cffi-sys::no-long-long
(progn
(defcallback sum-long-long :long-long
((a :long-long) (b :long-long))
(+ a b))
(defcallback sum-unsigned-long-long :unsigned-long-long
((a :unsigned-long-long) (b :unsigned-long-long))
(+ a b)))
(defcallback sum-float :float ((a :float) (b :float))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-double :double ((a :double) (b :double))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
#+(and scl long-float)
(defcallback sum-long-double :long-double ((a :long-double) (b :long-double))
;(format t "~%}}} a: ~A, b: ~A {{{~%" a b)
(+ a b))
(defcallback sum-pointer :pointer ((ptr :pointer) (offset :int))
(inc-pointer ptr offset))
(defcallback lisp-strcat :string ((a :string) (b :string))
(concatenate 'string a b))
(deftest callbacks.char
(expect-char-sum (get-callback 'sum-char))
1)
(deftest callbacks.unsigned-char
(expect-unsigned-char-sum (get-callback 'sum-unsigned-char))
1)
(deftest callbacks.short
(expect-short-sum (callback sum-short))
1)
(deftest callbacks.unsigned-short
(expect-unsigned-short-sum (callback sum-unsigned-short))
1)
(deftest callbacks.int
(expect-int-sum (callback sum-int))
1)
(deftest callbacks.unsigned-int
(expect-unsigned-int-sum (callback sum-unsigned-int))
1)
(deftest callbacks.long
(expect-long-sum (callback sum-long))
1)
(deftest callbacks.unsigned-long
(expect-unsigned-long-sum (callback sum-unsigned-long))
1)
#-cffi-sys::no-long-long
(progn
(deftest (callbacks.long-long :expected-to-fail (alexandria:featurep :openmcl))
(expect-long-long-sum (callback sum-long-long))
1)
(deftest callbacks.unsigned-long-long
(expect-unsigned-long-long-sum (callback sum-unsigned-long-long))
1))
(deftest callbacks.float
(expect-float-sum (callback sum-float))
1)
(deftest callbacks.double
(expect-double-sum (callback sum-double))
1)
#+(and scl long-float)
(deftest callbacks.long-double
(expect-long-double-sum (callback sum-long-double))
1)
(deftest callbacks.pointer
(expect-pointer-sum (callback sum-pointer))
1)
(deftest callbacks.string
(expect-strcat (callback lisp-strcat))
1)
#-cffi-sys::no-foreign-funcall
(defcallback return-a-string-not-nil :string ()
"abc")
#-cffi-sys::no-foreign-funcall
(deftest callbacks.string-not-docstring
(foreign-funcall-pointer (callback return-a-string-not-nil) () :string)
"abc")
(defcallback check-for-nil :boolean ((pointer :pointer))
(null pointer))
#-cffi-sys::no-foreign-funcall
(deftest callbacks.nil-for-null
(foreign-funcall-pointer (callback check-for-nil) nil
:pointer (null-pointer) :boolean)
nil)
;;; This one tests mem-aref too.
(defcfun "qsort" :void
(base :pointer)
(nmemb :int)
(size :int)
(fun-compar :pointer))
(defcallback < :int ((a :pointer) (b :pointer))
(let ((x (mem-ref a :int))
(y (mem-ref b :int)))
(cond ((> x y) 1)
((< x y) -1)
(t 0))))
(deftest callbacks.qsort
(with-foreign-object (array :int 10)
;; Initialize array.
(loop for i from 0 and n in '(7 2 10 4 3 5 1 6 9 8)
do (setf (mem-aref array :int i) n))
;; Sort it.
(qsort array 10 (foreign-type-size :int) (callback <))
;; Return it as a list.
(loop for i from 0 below 10
collect (mem-aref array :int i)))
(1 2 3 4 5 6 7 8 9 10))
;;; void callback
(defparameter *int* -1)
(defcfun "pass_int_ref" :void (f :pointer))
;;; CMUCL chokes on this one for some reason.
#-(and darwin cmucl)
(defcallback read-int-from-pointer :void ((a :pointer))
(setq *int* (mem-ref a :int)))
#+(and darwin cmucl)
(pushnew 'callbacks.void rt::*expected-failures*)
(deftest callbacks.void
(progn
(pass-int-ref (callback read-int-from-pointer))
*int*)
1984)
;;; test funcalling of a callback and also declarations inside
;;; callbacks.
#-cffi-sys::no-foreign-funcall
(progn
(defcallback sum-2 :int ((a :int) (b :int) (c :int))
(declare (ignore c))
(+ a b))
(deftest callbacks.funcall.1
(foreign-funcall-pointer (callback sum-2) () :int 2 :int 3 :int 1 :int)
5)
(defctype foo-float :float)
(defcallback sum-2f foo-float
((a foo-float) (b foo-float) (c foo-float) (d foo-float) (e foo-float))
"This one ignores the middle 3 arguments."
(declare (ignore b c))
(declare (ignore d))
(+ a e))
(deftest callbacks.funcall.2
(foreign-funcall-pointer (callback sum-2f) () foo-float 1.0 foo-float 2.0
foo-float 3.0 foo-float 4.0 foo-float 5.0
foo-float)
6.0))
;;; (cb-test :no-long-long t)
(defcfun "call_sum_127_no_ll" :long (cb :pointer))
;;; CMUCL and CCL choke on this one.
#-(or cmucl clozure
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(defcallback sum-127-no-ll :long
((a1 :unsigned-long) (a2 :pointer) (a3 :long) (a4 :double)
(a5 :unsigned-long) (a6 :float) (a7 :float) (a8 :int) (a9 :unsigned-int)
(a10 :double) (a11 :double) (a12 :double) (a13 :pointer)
(a14 :unsigned-short) (a15 :unsigned-short) (a16 :pointer) (a17 :long)
(a18 :long) (a19 :int) (a20 :short) (a21 :unsigned-short)
(a22 :unsigned-short) (a23 :char) (a24 :long) (a25 :pointer) (a26 :pointer)
(a27 :char) (a28 :unsigned-char) (a29 :unsigned-long) (a30 :short)
(a31 :int) (a32 :int) (a33 :unsigned-char) (a34 :short) (a35 :long)
(a36 :long) (a37 :pointer) (a38 :unsigned-short) (a39 :char) (a40 :double)
(a41 :unsigned-short) (a42 :pointer) (a43 :short) (a44 :unsigned-long)
(a45 :unsigned-short) (a46 :float) (a47 :unsigned-char) (a48 :short)
(a49 :float) (a50 :short) (a51 :char) (a52 :unsigned-long)
(a53 :unsigned-long) (a54 :char) (a55 :float) (a56 :long) (a57 :pointer)
(a58 :short) (a59 :float) (a60 :unsigned-int) (a61 :float)
(a62 :unsigned-int) (a63 :double) (a64 :unsigned-int) (a65 :unsigned-char)
(a66 :int) (a67 :long) (a68 :char) (a69 :short) (a70 :double) (a71 :int)
(a72 :pointer) (a73 :char) (a74 :unsigned-short) (a75 :pointer)
(a76 :unsigned-short) (a77 :pointer) (a78 :unsigned-long) (a79 :double)
(a80 :pointer) (a81 :long) (a82 :float) (a83 :unsigned-short)
(a84 :unsigned-short) (a85 :pointer) (a86 :float) (a87 :int)
(a88 :unsigned-int) (a89 :double) (a90 :float) (a91 :long) (a92 :pointer)
(a93 :unsigned-short) (a94 :float) (a95 :unsigned-char) (a96 :unsigned-char)
(a97 :float) (a98 :unsigned-int) (a99 :float) (a100 :unsigned-short)
(a101 :double) (a102 :unsigned-short) (a103 :unsigned-long)
(a104 :unsigned-int) (a105 :unsigned-long) (a106 :pointer)
(a107 :unsigned-char) (a108 :char) (a109 :char) (a110 :unsigned-short)
(a111 :unsigned-long) (a112 :float) (a113 :short) (a114 :pointer)
(a115 :long) (a116 :unsigned-short) (a117 :short) (a118 :double)
(a119 :short) (a120 :int) (a121 :char) (a122 :unsigned-long) (a123 :long)
(a124 :int) (a125 :pointer) (a126 :double) (a127 :unsigned-char))
(let ((args (list a1 (pointer-address a2) a3 (floor a4) a5 (floor a6)
(floor a7) a8 a9 (floor a10) (floor a11) (floor a12)
(pointer-address a13) a14 a15 (pointer-address a16) a17 a18
a19 a20 a21 a22 a23 a24 (pointer-address a25)
(pointer-address a26) a27 a28 a29 a30 a31 a32 a33 a34 a35
a36 (pointer-address a37) a38 a39 (floor a40) a41
(pointer-address a42) a43 a44 a45 (floor a46) a47 a48
(floor a49) a50 a51 a52 a53 a54 (floor a55) a56
(pointer-address a57) a58 (floor a59) a60 (floor a61) a62
(floor a63) a64 a65 a66 a67 a68 a69 (floor a70) a71
(pointer-address a72) a73 a74 (pointer-address a75) a76
(pointer-address a77) a78 (floor a79) (pointer-address a80)
a81 (floor a82) a83 a84 (pointer-address a85) (floor a86)
a87 a88 (floor a89) (floor a90) a91 (pointer-address a92)
a93 (floor a94) a95 a96 (floor a97) a98 (floor a99) a100
(floor a101) a102 a103 a104 a105 (pointer-address a106) a107
a108 a109 a110 a111 (floor a112) a113 (pointer-address a114)
a115 a116 a117 (floor a118) a119 a120 a121 a122 a123 a124
(pointer-address a125) (floor a126) a127)))
#-(and)
(loop for i from 1 and arg in args do
(format t "a~A: ~A~%" i arg))
(reduce #'+ args)))
#+(or openmcl cmucl (and darwin (or allegro lispworks)))
(push 'callbacks.bff.1 regression-test::*expected-failures*)
#+#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or))
(deftest callbacks.bff.1
(call-sum-127-no-ll (callback sum-127-no-ll))
2008547941)
;;; (cb-test)
#-(or cffi-sys::no-long-long
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(or) '(and)))
(progn
(defcfun "call_sum_127" :long-long (cb :pointer))
;;; CMUCL and CCL choke on this one.
#-(or cmucl clozure)
(defcallback sum-127 :long-long
((a1 :short) (a2 :char) (a3 :pointer) (a4 :float) (a5 :long) (a6 :double)
(a7 :unsigned-long-long) (a8 :unsigned-short) (a9 :unsigned-char)
(a10 :char) (a11 :char) (a12 :unsigned-short) (a13 :unsigned-long-long)
(a14 :unsigned-short) (a15 :long-long) (a16 :unsigned-short)
(a17 :unsigned-long-long) (a18 :unsigned-char) (a19 :unsigned-char)
(a20 :unsigned-long-long) (a21 :long-long) (a22 :char) (a23 :float)
(a24 :unsigned-int) (a25 :float) (a26 :float) (a27 :unsigned-int)
(a28 :float) (a29 :char) (a30 :unsigned-char) (a31 :long) (a32 :long-long)
(a33 :unsigned-char) (a34 :double) (a35 :long) (a36 :double)
(a37 :unsigned-int) (a38 :unsigned-short) (a39 :long-long)
(a40 :unsigned-int) (a41 :int) (a42 :unsigned-long-long) (a43 :long)
(a44 :short) (a45 :unsigned-int) (a46 :unsigned-int)
(a47 :unsigned-long-long) (a48 :unsigned-int) (a49 :long) (a50 :pointer)
(a51 :unsigned-char) (a52 :char) (a53 :long-long) (a54 :unsigned-short)
(a55 :unsigned-int) (a56 :float) (a57 :unsigned-char) (a58 :unsigned-long)
(a59 :long-long) (a60 :float) (a61 :long) (a62 :float) (a63 :int)
(a64 :float) (a65 :unsigned-short) (a66 :unsigned-long-long) (a67 :short)
(a68 :unsigned-long) (a69 :long) (a70 :char) (a71 :unsigned-short)
(a72 :long-long) (a73 :short) (a74 :double) (a75 :pointer)
(a76 :unsigned-int) (a77 :char) (a78 :unsigned-int) (a79 :pointer)
(a80 :pointer) (a81 :unsigned-char) (a82 :pointer) (a83 :unsigned-short)
(a84 :unsigned-char) (a85 :long) (a86 :pointer) (a87 :char) (a88 :long)
(a89 :unsigned-short) (a90 :unsigned-char) (a91 :double)
(a92 :unsigned-long-long) (a93 :unsigned-short) (a94 :unsigned-short)
(a95 :unsigned-int) (a96 :long) (a97 :char) (a98 :long) (a99 :char)
(a100 :short) (a101 :unsigned-short) (a102 :unsigned-long)
(a103 :unsigned-long) (a104 :short) (a105 :long-long) (a106 :long-long)
(a107 :long-long) (a108 :double) (a109 :unsigned-short)
(a110 :unsigned-char) (a111 :short) (a112 :unsigned-char) (a113 :long)
(a114 :long-long) (a115 :unsigned-long-long) (a116 :unsigned-int)
(a117 :unsigned-long) (a118 :unsigned-char) (a119 :long-long)
(a120 :unsigned-char) (a121 :unsigned-long-long) (a122 :double)
(a123 :unsigned-char) (a124 :long-long) (a125 :unsigned-char)
(a126 :char) (a127 :long-long))
(+ a1 a2 (pointer-address a3) (values (floor a4)) a5 (values (floor a6))
a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22
(values (floor a23)) a24 (values (floor a25)) (values (floor a26))
a27 (values (floor a28)) a29 a30 a31 a32 a33 (values (floor a34))
a35 (values (floor a36)) a37 a38 a39 a40 a41 a42 a43 a44 a45 a46 a47
a48 a49 (pointer-address a50) a51 a52 a53 a54 a55 (values (floor a56))
a57 a58 a59 (values (floor a60)) a61 (values (floor a62)) a63
(values (floor a64)) a65 a66 a67 a68 a69 a70 a71 a72 a73
(values (floor a74)) (pointer-address a75) a76 a77 a78
(pointer-address a79) (pointer-address a80) a81 (pointer-address a82)
a83 a84 a85 (pointer-address a86) a87 a88 a89 a90 (values (floor a91))
a92 a93 a94 a95 a96 a97 a98 a99 a100 a101 a102 a103 a104 a105 a106 a107
(values (floor a108)) a109 a110 a111 a112 a113 a114 a115 a116 a117 a118
a119 a120 a121 (values (floor a122)) a123 a124 a125 a126 a127))
#+(or openmcl cmucl)
(push 'callbacks.bff.2 rt::*expected-failures*)
(deftest callbacks.bff.2
(call-sum-127 (callback sum-127))
8166570665645582011))
;;; regression test: (callback non-existant-callback) should throw an error
(deftest callbacks.non-existant
(not (null (nth-value 1 (ignore-errors (callback doesnt-exist)))))
t)
;;; Handling many arguments of type double. Many lisps (used to) fail
;;; this one on darwin/ppc. This test might be bogus due to floating
;;; point arithmetic rounding errors.
;;;
;;; CMUCL chokes on this one.
#-(and darwin cmucl)
(defcallback double26 :double
((a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
(a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
(a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
(a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
(a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
(a26 :double))
(let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
#-(and)
(loop for i from 1 and arg in args do
(format t "a~A: ~A~%" i arg))
(reduce #'+ args)))
(defcfun "call_double26" :double (f :pointer))
#+(and darwin (or allegro cmucl))
(pushnew 'callbacks.double26 rt::*expected-failures*)
(deftest callbacks.double26
(call-double26 (callback double26))
81.64d0)
#+(and darwin cmucl)
(pushnew 'callbacks.double26.funcall rt::*expected-failures*)
#-cffi-sys::no-foreign-funcall
(deftest callbacks.double26.funcall
(foreign-funcall-pointer
(callback double26) () :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double)
81.64d0)
;;; Same as above, for floats.
#-(and darwin cmucl)
(defcallback float26 :float
((a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
(a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
(a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
(a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
(a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
(a26 :float))
(let ((args (list a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15
a16 a17 a18 a19 a20 a21 a22 a23 a24 a25 a26)))
#-(and)
(loop for i from 1 and arg in args do
(format t "a~A: ~A~%" i arg))
(reduce #'+ args)))
(defcfun "call_float26" :float (f :pointer))
#+(and darwin (or lispworks openmcl cmucl))
(pushnew 'callbacks.float26 regression-test::*expected-failures*)
(deftest callbacks.float26
(call-float26 (callback float26))
130.0)
#+(and darwin (or lispworks openmcl cmucl))
(pushnew 'callbacks.float26.funcall regression-test::*expected-failures*)
#-cffi-sys::no-foreign-funcall
(deftest callbacks.float26.funcall
(foreign-funcall-pointer
(callback float26) () :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0
:float)
130.0)
;;; Defining a callback as a non-toplevel form. Not portable. Doesn't
;;; work for CMUCL or Allegro.
#-(and)
(let ((n 42))
(defcallback non-toplevel-cb :int ()
n))
#-(and)
(deftest callbacks.non-toplevel
(foreign-funcall (callback non-toplevel-cb) :int)
42)
;;;# Stdcall
#+(and x86 (not cffi-sys::no-stdcall))
(progn
(defcallback (stdcall-cb :convention :stdcall) :int
((a :int) (b :int) (c :int))
(+ a b c))
(defcfun "call_stdcall_fun" :int
(f :pointer))
(deftest callbacks.stdcall.1
(call-stdcall-fun (callback stdcall-cb))
42))
;;; RT: many of the %DEFCALLBACK implementations wouldn't handle
;;; uninterned symbols.
(deftest callbacks.uninterned
(values (defcallback #1=#:foo :void ())
(pointerp (callback #1#)))
#1# t)

9
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/compile.bat Normal file
View file

@ -0,0 +1,9 @@
rem
rem script for compiling the test lib with the free MSVC++ toolkit.
rem
cl /LD /DWIN32=1 /Tc libtest.c
del libtest.obj libtest.exp
cl /LD /DWIN32=1 /Tc libtest2.c
del libtest2.obj libtest2.exp

536
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/defcfun.lisp Normal file
View file

@ -0,0 +1,536 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; defcfun.lisp --- Tests function definition and calling.
;;;
;;; 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)
(deftest defcfun.parse-name-and-options.1
(multiple-value-bind (lisp-name foreign-name)
(let ((*package* (find-package '#:cffi-tests)))
(cffi::parse-name-and-options "foo_bar"))
(list lisp-name foreign-name))
(foo-bar "foo_bar"))
(deftest defcfun.parse-name-and-options.2
(multiple-value-bind (lisp-name foreign-name)
(let ((*package* (find-package '#:cffi-tests)))
(cffi::parse-name-and-options "foo_bar" t))
(list lisp-name foreign-name))
(*foo-bar* "foo_bar"))
(deftest defcfun.parse-name-and-options.3
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options 'foo-bar)
(list lisp-name foreign-name))
(foo-bar "foo_bar"))
(deftest defcfun.parse-name-and-options.4
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '*foo-bar* t)
(list lisp-name foreign-name))
(*foo-bar* "foo_bar"))
(deftest defcfun.parse-name-and-options.5
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '("foo_bar" foo-baz))
(list lisp-name foreign-name))
(foo-baz "foo_bar"))
(deftest defcfun.parse-name-and-options.6
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '("foo_bar" *foo-baz*) t)
(list lisp-name foreign-name))
(*foo-baz* "foo_bar"))
(deftest defcfun.parse-name-and-options.7
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '(foo-baz "foo_bar"))
(list lisp-name foreign-name))
(foo-baz "foo_bar"))
(deftest defcfun.parse-name-and-options.8
(multiple-value-bind (lisp-name foreign-name)
(cffi::parse-name-and-options '(*foo-baz* "foo_bar") t)
(list lisp-name foreign-name))
(*foo-baz* "foo_bar"))
;;;# Name translation
(deftest translate-underscore-separated-name.to-symbol
(let ((*package* (find-package '#:cffi-tests)))
(translate-underscore-separated-name "some_name_with_underscores"))
some-name-with-underscores)
(deftest translate-underscore-separated-name.to-string
(translate-underscore-separated-name 'some-name-with-underscores)
"some_name_with_underscores")
(deftest translate-camelcase-name.to-symbol
(let ((*package* (find-package '#:cffi-tests)))
(translate-camelcase-name "someXmlFunction"))
some-xml-function)
(deftest translate-camelcase-name.to-string
(translate-camelcase-name 'some-xml-function)
"someXmlFunction")
(deftest translate-camelcase-name.to-string-upper
(translate-camelcase-name 'some-xml-function :upper-initial-p t)
"SomeXmlFunction")
(deftest translate-camelcase-name.to-symbol-special
(let ((*package* (find-package '#:cffi-tests)))
(translate-camelcase-name "someXMLFunction" :special-words '("XML")))
some-xml-function)
(deftest translate-camelcase-name.to-string-special
(translate-camelcase-name 'some-xml-function :special-words '("XML"))
"someXMLFunction")
(deftest translate-name-from-foreign.function
(let ((*package* (find-package '#:cffi-tests)))
(translate-name-from-foreign "some_xml_name" *package*))
some-xml-name)
(deftest translate-name-from-foreign.var
(let ((*package* (find-package '#:cffi-tests)))
(translate-name-from-foreign "some_xml_name" *package* t))
*some-xml-name*)
(deftest translate-name-to-foreign.function
(translate-name-to-foreign 'some-xml-name *package*)
"some_xml_name")
(deftest translate-name-to-foreign.var
(translate-name-to-foreign '*some-xml-name* *package* t)
"some_xml_name")
;;;# Calling with built-in c types
;;;
;;; Tests calling standard C library functions both passing
;;; and returning each built-in type. (adapted from funcall.lisp)
(defcfun "toupper" :char
"toupper docstring"
(char :char))
(deftest defcfun.char
(toupper (char-code #\a))
#.(char-code #\A))
(deftest defcfun.docstring
(documentation 'toupper 'function)
"toupper docstring")
(defcfun ("abs" c-abs) :int
(n :int))
(deftest defcfun.int
(c-abs -100)
100)
(defcfun "labs" :long
(n :long))
(deftest defcfun.long
(labs -131072)
131072)
#-cffi-features:no-long-long
(progn
(defcfun "my_llabs" :long-long
(n :long-long))
(deftest defcfun.long-long
(my-llabs -9223372036854775807)
9223372036854775807)
(defcfun "ullong" :unsigned-long-long
(n :unsigned-long-long))
#+allegro ; lp#914500
(pushnew 'defcfun.unsigned-long-long rt::*expected-failures*)
(deftest defcfun.unsigned-long-long
(let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
(eql ullong-max (ullong ullong-max)))
t))
(defcfun "my_sqrtf" :float
(n :float))
(deftest defcfun.float
(my-sqrtf 16.0)
4.0)
(defcfun ("sqrt" c-sqrt) :double
(n :double))
(deftest defcfun.double
(c-sqrt 36.0d0)
6.0d0)
#+(and scl long-float)
(defcfun ("sqrtl" c-sqrtl) :long-double
(n :long-double))
#+(and scl long-float)
(deftest defcfun.long-double
(c-sqrtl 36.0l0)
6.0l0)
(defcfun "strlen" :int
(n :string))
(deftest defcfun.string.1
(strlen "Hello")
5)
(defcfun "strcpy" (:pointer :char)
(dest (:pointer :char))
(src :string))
(defcfun "strcat" (:pointer :char)
(dest (:pointer :char))
(src :string))
(deftest defcfun.string.2
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(strcpy s "Hello")
(strcat s ", world!"))
"Hello, world!")
(defcfun "strerror" :string
(n :int))
(deftest defcfun.string.3
(typep (strerror 1) 'string)
t)
;;; Regression test. Allegro would warn on direct calls to
;;; functions with no arguments.
;;;
;;; Also, let's check if void functions will return NIL.
;;;
;;; Check if a docstring without arguments doesn't cause problems.
(defcfun "noargs" :int
"docstring")
(deftest defcfun.noargs
(noargs)
42)
(defcfun "noop" :void)
#+(or allegro openmcl ecl) (pushnew 'defcfun.noop rt::*expected-failures*)
(deftest defcfun.noop
(noop)
#|no values|#)
;;;# Calling varargs functions
(defcfun "sum_double_arbitrary" :double (n :int) &rest)
(deftest defcfun.varargs.nostdlib
(sum-double-arbitrary
26
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0)
81.64d0)
(defcfun "sprintf" :int
"sprintf docstring"
(str (:pointer :char))
(control :string)
&rest)
;;; CLISP and ABCL discard macro docstrings.
#+(or clisp abcl)
(pushnew 'defcfun.varargs.docstrings rt::*expected-failures*)
(deftest defcfun.varargs.docstrings
(documentation 'sprintf 'function)
"sprintf docstring")
(deftest defcfun.varargs.char
(with-foreign-pointer-as-string (s 100)
(sprintf s "%c" :char 65))
"A")
(deftest defcfun.varargs.short
(with-foreign-pointer-as-string (s 100)
(sprintf s "%d" :short 42))
"42")
(deftest defcfun.varargs.int
(with-foreign-pointer-as-string (s 100)
(sprintf s "%d" :int 1000))
"1000")
(deftest defcfun.varargs.long
(with-foreign-pointer-as-string (s 100)
(sprintf s "%ld" :long 131072))
"131072")
(deftest defcfun.varargs.float
(with-foreign-pointer-as-string (s 100)
(sprintf s "%.2f" :float (float pi)))
"3.14")
(deftest defcfun.varargs.double
(with-foreign-pointer-as-string (s 100)
(sprintf s "%.2f" :double (float pi 1.0d0)))
"3.14")
#+(and scl long-float)
(deftest defcfun.varargs.long-double
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(sprintf s "%.2Lf" :long-double pi))
"3.14")
(deftest defcfun.varargs.string
(with-foreign-pointer-as-string (s 100)
(sprintf s "%s, %s!" :string "Hello" :string "world"))
"Hello, world!")
;;; (let ((rettype (find-type :long))
;;; (arg-types (n-random-types-no-ll 127)))
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
#+(and (not ecl)
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:and) '(:or)))
(progn
(defcfun "sum_127_no_ll" :long
(a1 :long) (a2 :unsigned-long) (a3 :short) (a4 :unsigned-short) (a5 :float)
(a6 :double) (a7 :unsigned-long) (a8 :float) (a9 :unsigned-char)
(a10 :unsigned-short) (a11 :short) (a12 :unsigned-long) (a13 :double)
(a14 :long) (a15 :unsigned-int) (a16 :pointer) (a17 :unsigned-int)
(a18 :unsigned-short) (a19 :long) (a20 :float) (a21 :pointer) (a22 :float)
(a23 :int) (a24 :int) (a25 :unsigned-short) (a26 :long) (a27 :long)
(a28 :double) (a29 :unsigned-char) (a30 :unsigned-int) (a31 :unsigned-int)
(a32 :int) (a33 :unsigned-short) (a34 :unsigned-int) (a35 :pointer)
(a36 :double) (a37 :double) (a38 :long) (a39 :short) (a40 :unsigned-short)
(a41 :long) (a42 :char) (a43 :long) (a44 :unsigned-short) (a45 :pointer)
(a46 :int) (a47 :unsigned-int) (a48 :double) (a49 :unsigned-char)
(a50 :unsigned-char) (a51 :float) (a52 :int) (a53 :unsigned-short)
(a54 :double) (a55 :short) (a56 :unsigned-char) (a57 :unsigned-long)
(a58 :float) (a59 :float) (a60 :float) (a61 :pointer) (a62 :pointer)
(a63 :unsigned-int) (a64 :unsigned-long) (a65 :char) (a66 :short)
(a67 :unsigned-short) (a68 :unsigned-long) (a69 :pointer) (a70 :float)
(a71 :double) (a72 :long) (a73 :unsigned-long) (a74 :short)
(a75 :unsigned-int) (a76 :unsigned-short) (a77 :int) (a78 :unsigned-short)
(a79 :char) (a80 :double) (a81 :short) (a82 :unsigned-char) (a83 :float)
(a84 :char) (a85 :int) (a86 :double) (a87 :unsigned-char) (a88 :int)
(a89 :unsigned-long) (a90 :double) (a91 :short) (a92 :short)
(a93 :unsigned-int) (a94 :unsigned-char) (a95 :float) (a96 :long)
(a97 :float) (a98 :long) (a99 :long) (a100 :int) (a101 :int)
(a102 :unsigned-int) (a103 :char) (a104 :char) (a105 :unsigned-short)
(a106 :unsigned-int) (a107 :unsigned-short) (a108 :unsigned-short)
(a109 :int) (a110 :long) (a111 :char) (a112 :double) (a113 :unsigned-int)
(a114 :char) (a115 :short) (a116 :unsigned-long) (a117 :unsigned-int)
(a118 :short) (a119 :unsigned-char) (a120 :float) (a121 :pointer)
(a122 :double) (a123 :int) (a124 :long) (a125 :char) (a126 :unsigned-short)
(a127 :float))
(deftest defcfun.bff.1
(sum-127-no-ll
1442906394 520035521 -4715 50335 -13557.0 -30892.0d0 24061483 -23737.0
22 2348 4986 104895680 8073.0d0 -571698147 102484400
(make-pointer 507907275) 12733353 7824 -1275845284 13602.0
(make-pointer 286958390) -8042.0 -773681663 -1289932452 31199 -154985357
-170994216 16845.0d0 177 218969221 2794350893 6068863 26327 127699339
(make-pointer 184352771) 18512.0d0 -12345.0d0 -179853040 -19981 37268
-792845398 116 -1084653028 50494 (make-pointer 2105239646) -1710519651
1557813312 2839.0d0 90 180 30580.0 -532698978 8623 9537.0d0 -10882 54
184357206 14929.0 -8190.0 -25615.0 (make-pointer 235310526)
(make-pointer 220476977) 7476055 1576685 -117 -11781 31479 23282640
(make-pointer 8627281) -17834.0 10391.0d0 -1904504370 114393659 -17062
637873619 16078 -891210259 8107 0 760.0d0 -21268 104 14133.0 10
588598141 310.0d0 20 1351785456 16159552 -10121.0d0 -25866 24821
68232851 60 -24132.0 -1660411658 13387.0 -786516668 -499825680
-1128144619 111849719 2746091587 -2 95 14488 326328135 64781 18204
150716680 -703859275 103 16809.0d0 852235610 -43 21088 242356110
324325428 -22380 23 24814.0 (make-pointer 40362014) -14322.0d0
-1864262539 523684371 -21 49995 -29175.0)
796447501))
;;; (let ((rettype (find-type :long-long))
;;; (arg-types (n-random-types 127)))
;;; (c-function rettype arg-types)
;;; (gen-function-test rettype arg-types))
#-(or ecl cffi-sys::no-long-long
#.(cl:if (cl:>= cl:lambda-parameters-limit 127) '(:or) '(:and)))
(progn
(defcfun "sum_127" :long-long
(a1 :pointer) (a2 :pointer) (a3 :float) (a4 :unsigned-long) (a5 :pointer)
(a6 :long-long) (a7 :double) (a8 :double) (a9 :unsigned-short) (a10 :int)
(a11 :long-long) (a12 :long) (a13 :short) (a14 :unsigned-int) (a15 :long)
(a16 :unsigned-char) (a17 :int) (a18 :double) (a19 :short) (a20 :short)
(a21 :long-long) (a22 :unsigned-int) (a23 :unsigned-short) (a24 :short)
(a25 :pointer) (a26 :short) (a27 :unsigned-short) (a28 :unsigned-short)
(a29 :int) (a30 :long-long) (a31 :pointer) (a32 :int) (a33 :unsigned-long)
(a34 :unsigned-long) (a35 :pointer) (a36 :unsigned-long-long) (a37 :float)
(a38 :int) (a39 :short) (a40 :pointer) (a41 :unsigned-long-long)
(a42 :long-long) (a43 :unsigned-long) (a44 :unsigned-long)
(a45 :unsigned-long-long) (a46 :unsigned-long) (a47 :char) (a48 :double)
(a49 :long) (a50 :unsigned-int) (a51 :int) (a52 :short) (a53 :pointer)
(a54 :long) (a55 :unsigned-long-long) (a56 :int) (a57 :unsigned-short)
(a58 :unsigned-long-long) (a59 :float) (a60 :pointer) (a61 :float)
(a62 :unsigned-short) (a63 :unsigned-long) (a64 :float) (a65 :unsigned-int)
(a66 :unsigned-long-long) (a67 :pointer) (a68 :double)
(a69 :unsigned-long-long) (a70 :double) (a71 :double) (a72 :long-long)
(a73 :pointer) (a74 :unsigned-short) (a75 :long) (a76 :pointer) (a77 :short)
(a78 :double) (a79 :long) (a80 :unsigned-char) (a81 :pointer)
(a82 :unsigned-char) (a83 :long) (a84 :double) (a85 :pointer) (a86 :int)
(a87 :double) (a88 :unsigned-char) (a89 :double) (a90 :short) (a91 :long)
(a92 :int) (a93 :long) (a94 :double) (a95 :unsigned-short)
(a96 :unsigned-int) (a97 :int) (a98 :char) (a99 :long-long) (a100 :double)
(a101 :float) (a102 :unsigned-long) (a103 :short) (a104 :pointer)
(a105 :float) (a106 :long-long) (a107 :int) (a108 :long-long)
(a109 :long-long) (a110 :double) (a111 :unsigned-long-long) (a112 :double)
(a113 :unsigned-long) (a114 :char) (a115 :char) (a116 :unsigned-long)
(a117 :short) (a118 :unsigned-char) (a119 :unsigned-char) (a120 :int)
(a121 :int) (a122 :float) (a123 :unsigned-char) (a124 :unsigned-char)
(a125 :double) (a126 :unsigned-long-long) (a127 :char))
#+(and sbcl x86) (push 'defcfun.bff.2 rtest::*expected-failures*)
(deftest defcfun.bff.2
(sum-127
(make-pointer 2746181372) (make-pointer 177623060) -32334.0 3158055028
(make-pointer 242315091) 4288001754991016425 -21047.0d0 287.0d0 18722
243379286 -8677366518541007140 581399424 -13872 4240394881 1353358999
226 969197676 -26207.0d0 6484 11150 1241680089902988480 106068320 61865
2253 (make-pointer 866809333) -31613 35616 11715 1393601698
8940888681199591845 (make-pointer 1524606024) 805638893 3315410736
3432596795 (make-pointer 1490355706) 696175657106383698 -25438.0
1294381547 26724 (make-pointer 3196569545) 2506913373410783697
-4405955718732597856 4075932032 3224670123 2183829215657835866
1318320964 -22 -3786.0d0 -2017024146 1579225515 -626617701 -1456
(make-pointer 3561444187) 395687791 1968033632506257320 -1847773261
48853 142937735275669133 -17974.0 (make-pointer 2791749948) -14140.0
2707 3691328585 3306.0 1132012981 303633191773289330
(make-pointer 981183954) 9114.0d0 8664374572369470 -19013.0d0
-10288.0d0 -3679345119891954339 (make-pointer 3538786709) 23761
-154264605 (make-pointer 2694396308) 7023 997.0d0 1009561368 241
(make-pointer 2612292671) 48 1431872408 -32675.0d0
(make-pointer 1587599336) 958916472 -9857.0d0 111 -14370.0d0 -7308
-967514912 488790941 2146978095 -24111.0d0 13711 86681861 717987770
111 1013402998690933877 17234.0d0 -8772.0 3959216275 -8711
(make-pointer 3142780851) 9480.0 -3820453146461186120 1616574376
-3336232268263990050 -1906114671562979758 -27925.0d0 9695970875869913114
27033.0d0 1096518219 -12 104 3392025403 -27911 60 89 509297051
-533066551 29158.0 110 54 -9802.0d0 593950442165910888 -79)
7758614658402721936))
;;; regression test: defining an undefined foreign function should only
;;; throw some sort of warning, not signal an error.
#+(or cmucl (and sbcl (or (not linkage-table) win32)))
(pushnew 'defcfun.undefined rt::*expected-failures*)
(deftest defcfun.undefined
(progn
(eval '(defcfun ("undefined_foreign_function" undefined-foreign-function) :void))
(compile 'undefined-foreign-function)
t)
t)
;;; Test whether all doubles are passed correctly. On some platforms, eg.
;;; darwin/ppc, some are passed on registers others on the stack.
(defcfun "sum_double26" :double
(a1 :double) (a2 :double) (a3 :double) (a4 :double) (a5 :double)
(a6 :double) (a7 :double) (a8 :double) (a9 :double) (a10 :double)
(a11 :double) (a12 :double) (a13 :double) (a14 :double) (a15 :double)
(a16 :double) (a17 :double) (a18 :double) (a19 :double) (a20 :double)
(a21 :double) (a22 :double) (a23 :double) (a24 :double) (a25 :double)
(a26 :double))
(deftest defcfun.double26
(sum-double26 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0 3.14d0
3.14d0 3.14d0 3.14d0 3.14d0 3.14d0)
81.64d0)
;;; Same as above for floats.
(defcfun "sum_float26" :float
(a1 :float) (a2 :float) (a3 :float) (a4 :float) (a5 :float)
(a6 :float) (a7 :float) (a8 :float) (a9 :float) (a10 :float)
(a11 :float) (a12 :float) (a13 :float) (a14 :float) (a15 :float)
(a16 :float) (a17 :float) (a18 :float) (a19 :float) (a20 :float)
(a21 :float) (a22 :float) (a23 :float) (a24 :float) (a25 :float)
(a26 :float))
(deftest defcfun.float26
(sum-float26 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0
5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0 5.0)
130.0)
;;;# Namespaces
#-cffi-sys::flat-namespace
(progn
(defcfun ("ns_function" ns-fun1 :library libtest) :boolean)
(defcfun ("ns_function" ns-fun2 :library libtest2) :boolean)
(deftest defcfun.namespace.1
(values (ns-fun1) (ns-fun2))
t nil))
;;;# stdcall
#+(and x86 windows (not cffi-sys::no-stdcall))
(progn
(defcfun ("stdcall_fun@12" stdcall-fun :convention :stdcall) :int
(a :int)
(b :int)
(c :int))
(deftest defcfun.stdcall.1
(loop repeat 100 do (stdcall-fun 1 2 3)
finally (return (stdcall-fun 1 2 3)))
6))

231
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/enum.lisp Normal file
View file

@ -0,0 +1,231 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; enum.lisp --- Tests on C enums.
;;;
;;; Copyright (C) 2005-2006, 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)
(defctype numeros-base-type :int)
(defcenum (numeros numeros-base-type)
(:one 1)
:two
:three
:four
(:forty-one 41)
:forty-two)
(defcfun "check_enums" :int
(%one numeros)
(%two numeros)
(%three numeros)
(%four numeros)
(%forty-one numeros)
(%forty-two numeros))
(deftest enum.1
(check-enums :one :two :three 4 :forty-one :forty-two)
1)
(defcenum another-boolean :false :true)
(defcfun "return_enum" another-boolean (x :uint))
(deftest enum.2
(and (eq :false (return-enum 0))
(eq :true (return-enum 1)))
t)
(defctype yet-another-boolean another-boolean)
(defcfun ("return_enum" return-enum2) yet-another-boolean
(x yet-another-boolean))
(deftest enum.3
(and (eq :false (return-enum2 :false))
(eq :true (return-enum2 :true)))
t)
(defctype numeros-typedef numeros)
(deftest enum.typedef.1
(eq (foreign-enum-keyword 'numeros-typedef 1)
(foreign-enum-keyword 'numeros 1))
t)
(deftest enum.typedef.2
(eql (foreign-enum-value 'numeros-typedef :four)
(foreign-enum-value 'numeros :four))
t)
(defcenum enum-size.int
(:one 1)
(enum-size-int #.(1- (expt 2 (1- (* (foreign-type-size :unsigned-int) 8)))))
(enum-size-negative-int #.(- (1- (expt 2 (1- (* (foreign-type-size :unsigned-int) 8))))))
(:two 2))
(defcenum enum-size.uint
(:one 1)
(enum-size-uint #.(1- (expt 2 (* (foreign-type-size :unsigned-int) 8))))
(:two 2))
(deftest enum.size
(mapcar (alexandria:compose 'cffi::unparse-type
'cffi::actual-type
'cffi::parse-type)
(list 'enum-size.int
'enum-size.uint))
;; The C standard only has weak constraints on the size of integer types, so
;; we cannot really test more than one type in a platform independent way due
;; to the possible overlaps.
(:int
:unsigned-int))
(deftest enum.size.members
(mapcar (alexandria:conjoin 'boundp 'constantp)
'(enum-size-int enum-size-negative-int enum-size-uint))
(t t t))
(deftest enum.size.error-when-too-large
(expecting-error
(eval '(defcenum enum-size-too-large
(:too-long #.(expt 2 129)))))
:error)
;; There are some projects that use non-integer base type. It's not in
;; adherence with the C standard, but we also don't lose much by
;; allowing it.
(defcenum (enum.double :double)
(:one 1)
(:two 2d0)
(:three 3.42)
:four)
(deftest enum.double
(values-list
(mapcar (alexandria:curry 'foreign-enum-value 'enum.double)
'(:one :two :three :four)))
1
2.0d0
3.42
4.42)
;;;# Bitfield tests
;;; Regression test: defbitfield was misbehaving when the first value
;;; was provided.
(deftest bitfield.1
(eval '(defbitfield (bf1 :long)
(:foo 0)))
bf1)
(defbitfield bf2
one
two
four
eight
sixteen
(bf2.outlier 42)
thirty-two
sixty-four)
(deftest bitfield.2
(mapcar (lambda (symbol)
(foreign-bitfield-value 'bf2 (list symbol)))
'(one two four eight sixteen thirty-two sixty-four))
(1 2 4 8 16 32 64))
(deftest bitfield.2.outlier
(mapcar (lambda (symbol)
(foreign-bitfield-value 'bf2 (list symbol)))
'(one two four eight sixteen thirty-two sixty-four))
(1 2 4 8 16 32 64))
(defbitfield (bf3 :int)
(three 3)
one
(seven 7)
two
(eight 8)
sixteen)
;;; Non-single-bit numbers must not influence the progression of
;;; implicit values. Single bits larger than any before *must*
;;; influence said progression.
(deftest bitfield.3
(mapcar (lambda (symbol)
(foreign-bitfield-value 'bf3 (list symbol)))
'(one two sixteen))
(1 2 16))
(defbitfield bf4
;; zero will be a simple enum member because it's not a valid mask
(zero 0)
one
two
four
(three 3)
(sixteen 16))
;;; Yet another edge case with the 0...
(deftest bitfield.4
;; These should macroexpand to the literals in Slime
;; due to the compiler macros. Same below.
(values (foreign-bitfield-value 'bf4 ())
(foreign-bitfield-value 'bf4 'one)
(foreign-bitfield-value 'bf4 '(one two))
(foreign-bitfield-value 'bf4 '(three)) ; or should it signal an error?
(foreign-bitfield-value 'bf4 '(sixteen)))
0
1
3
3
16)
(deftest bitfield.4b
(values (foreign-bitfield-symbols 'bf4 0)
(foreign-bitfield-symbols 'bf4 1)
(foreign-bitfield-symbols 'bf4 3)
(foreign-bitfield-symbols 'bf4 8)
(foreign-bitfield-symbols 'bf4 16))
nil
(one)
(one two)
nil
(sixteen))
(deftest bitfield.translators
(with-foreign-object (bf 'bf4 2)
(setf (mem-aref bf 'bf4 0) 1)
(setf (mem-aref bf 'bf4 1) 3)
(values (mem-aref bf 'bf4 0)
(mem-aref bf 'bf4 1)))
(one)
(one two))
#+nil
(deftest bitfield.base-type-error
(expecting-error
(eval '(defbitfield (bf1 :float)
(:foo 0))))
:error)

309
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/foreign-globals.lisp Normal file
View file

@ -0,0 +1,309 @@
;;;; -*- 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)

199
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/fsbv.lisp Normal file
View file

@ -0,0 +1,199 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; fsbv.lisp --- Tests of foreign structure by value calls.
;;;
;;; Copyright (C) 2011, Liam M. Healy
;;;
;;; 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)
;; Requires struct.lisp
(defcfun "sumpair" :int
(p (:struct struct-pair)))
(defcfun "makepair" (:struct struct-pair)
(condition :bool))
(defcfun "doublepair" (:struct struct-pair)
(p (:struct struct-pair)))
(defcfun "prodsumpair" :double
(p (:struct struct-pair+double)))
(defcfun "doublepairdouble" (:struct struct-pair+double)
(p (:struct struct-pair+double)))
;;; Call struct by value
(deftest fsbv.1
(sumpair '(1 . 2))
3)
;;; See lp#1528719
(deftest (fsbv.wfo :expected-to-fail t)
(with-foreign-object (arg '(:struct struct-pair))
(convert-into-foreign-memory '(40 . 2) '(:struct struct-pair) arg)
(sumpair arg))
42)
;;; Call and return struct by value
(deftest fsbv.2
(doublepair '(1 . 2))
(2 . 4))
;;; return struct by value
(deftest (fsbv.makepair.1 :expected-to-fail t)
(makepair nil)
(-127 . 43))
(deftest (fsbv.makepair.2 :expected-to-fail t)
(makepair t)
(-127 . 42))
;;; Call recursive structure by value
(deftest fsbv.3
(prodsumpair '(pr (a 4 b 5) dbl 2.5d0))
22.5d0)
;;; Call and return recursive structure by value
(deftest fsbv.4
(let ((ans (doublepairdouble '(pr (a 4 b 5) dbl 2.5d0))))
(values (getf (getf ans 'pr) 'a)
(getf (getf ans 'pr) 'b)
(getf ans 'dbl)))
8
10
5.0d0)
(defcstruct (struct-with-array :size 6)
(s1 (:array :char 6)))
(defcfun "zork" :void
(p (:struct struct-with-array)))
;;; Typedef fsbv test
(defcfun ("sumpair" sumpair2) :int
(p struct-pair-typedef1))
(deftest fsbv.5
(sumpair2 '(1 . 2))
3)
(defcfun "returnpairpointer" (:pointer (:struct struct-pair))
(ignored (:struct struct-pair)))
(deftest fsbv.return-a-pointer
(let ((ptr (returnpairpointer '(1 . 2))))
(+ (foreign-slot-value ptr '(:struct struct-pair) 'a)
(foreign-slot-value ptr '(:struct struct-pair) 'b)))
42)
;;; Test ulonglong on no-long-long implementations.
(defcfun "ullsum" :unsigned-long-long
(a :unsigned-long-long) (b :unsigned-long-long))
(deftest fsbv.6
(ullsum #x10DEADBEEF #x2300000000)
#x33DEADBEEF)
;;; Combine structures by value with a string argument
(defcfun "stringlenpair" (:struct struct-pair)
(s :string)
(p (:struct struct-pair)))
(deftest fsbv.7
(stringlenpair "abc" '(1 . 2))
(3 . 6))
;;; Combine structures by value with an enum argument
(defcfun "enumpair" (:int)
(e numeros)
(p (:struct struct-pair)))
(deftest fsbv.8
(enumpair :two '(1 . 2))
5)
;;; returning struct with bitfield member (bug #1474631)
(defbitfield (struct-bitfield :unsigned-int)
(:a 1)
(:b 2))
(defcstruct bitfield-struct
(b struct-bitfield))
(defcfun "structbitfield" (:struct bitfield-struct)
(x :unsigned-int))
(defctype struct-bitfield-typedef struct-bitfield)
(defcstruct bitfield-struct.2
(b struct-bitfield-typedef))
(defcfun ("structbitfield" structbitfield.2) (:struct bitfield-struct.2)
(x :unsigned-int))
;; these would get stuck in an infinite loop previously
(deftest fsbv.struct-bitfield.0
(structbitfield 0)
(b nil))
(deftest fsbv.struct-bitfield.1
(structbitfield 1)
(b (:a)))
(deftest fsbv.struct-bitfield.2
(structbitfield 2)
(b (:b)))
(deftest fsbv.struct-bitfield.3
(structbitfield.2 2)
(b (:b)))
;;; Test for a discrepancy between normal and fsbv return values
(cffi:define-foreign-type int-return-code (cffi::foreign-type-alias)
()
(:default-initargs :actual-type (cffi::parse-type :int))
(:simple-parser int-return-code))
(defmethod cffi:expand-from-foreign (value (type int-return-code))
;; NOTE: strictly speaking it should be
;; (cffi:convert-from-foreign ,value :int), but it's irrelevant in this case
`(let ((return-code ,value))
(check-type return-code integer)
return-code))
(defcfun (noargs-with-typedef "noargs") int-return-code)
(deftest fsbv.noargs-with-typedef ; for reference, not an FSBV call
(noargs-with-typedef)
42)
(defcfun (sumpair-with-typedef "sumpair") int-return-code
(p (:struct struct-pair)))
(deftest (fsbv.return-value-typedef)
(sumpair-with-typedef '(40 . 2))
42)

245
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/funcall.lisp Normal file
View file

@ -0,0 +1,245 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; funcall.lisp --- Tests function calling.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; 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)
;;;# Calling with Built-In C Types
;;;
;;; Tests calling standard C library functions both passing and
;;; returning each built-in type.
;;; Don't run these tests if the implementation does not support
;;; foreign-funcall.
#-cffi-sys::no-foreign-funcall
(progn
(deftest funcall.char
(foreign-funcall "toupper" :char (char-code #\a) :char)
#.(char-code #\A))
(deftest funcall.int.1
(foreign-funcall "abs" :int -100 :int)
100)
(defun funcall-abs (n)
(foreign-funcall "abs" :int n :int))
;;; regression test: lispworks's %foreign-funcall based on creating
;;; and caching foreign-funcallables at macro-expansion time.
(deftest funcall.int.2
(funcall-abs -42)
42)
(deftest funcall.long
(foreign-funcall "labs" :long -131072 :long)
131072)
#-cffi-sys::no-long-long
(deftest funcall.long-long
(foreign-funcall "my_llabs" :long-long -9223372036854775807 :long-long)
9223372036854775807)
#-cffi-sys::no-long-long
(deftest funcall.unsigned-long-long
(let ((ullong-max (1- (expt 2 (* 8 (foreign-type-size :unsigned-long-long))))))
(eql ullong-max
(foreign-funcall "ullong" :unsigned-long-long ullong-max
:unsigned-long-long)))
t)
(deftest funcall.float
(foreign-funcall "my_sqrtf" :float 16.0 :float)
4.0)
(deftest funcall.double
(foreign-funcall "sqrt" :double 36.0d0 :double)
6.0d0)
#+(and scl long-float)
(deftest funcall.long-double
(foreign-funcall "sqrtl" :long-double 36.0l0 :long-double)
6.0l0)
(deftest funcall.string.1
(foreign-funcall "strlen" :string "Hello" :int)
5)
(deftest funcall.string.2
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall "strcpy" :pointer s :string "Hello" :pointer)
(foreign-funcall "strcat" :pointer s :string ", world!" :pointer))
"Hello, world!")
(deftest funcall.string.3
(with-foreign-pointer (ptr 100)
(lisp-string-to-foreign "Hello, " ptr 8)
(foreign-funcall "strcat" :pointer ptr :string "world!" :string))
"Hello, world!")
;;;# Calling Varargs Functions
(deftest funcall.varargs.nostdlib
(foreign-funcall-varargs
"sum_double_arbitrary" (:int 26)
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0
:double)
81.64d0)
;; The CHAR argument must be passed as :INT because chars are promoted
;; to ints when passed as variable arguments.
(deftest funcall.varargs.char
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" (:pointer s :string "%c") :int 65 :int))
"A")
(deftest funcall.varargs.int
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" (:pointer s :string "%d") :int 1000 :int))
"1000")
(deftest funcall.varargs.long
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" (:pointer s :string "%ld")
:long 131072 :int))
"131072")
;;; There is no FUNCALL.VARARGS.FLOAT as floats are promoted to double
;;; when passed as variable arguments. Currently this fails in SBCL
;;; and CMU CL on Darwin/ppc.
(deftest funcall.varargs.double
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" (:pointer s :string "%.2f") :double (coerce pi 'double-float) :int))
"3.14")
#+(and scl long-float)
(deftest funcall.varargs.long-double
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" :pointer s :string "%.2Lf" :long-double pi :int))
"3.14")
(deftest funcall.varargs.string
(with-foreign-pointer-as-string (s 100)
(setf (mem-ref s :char) 0)
(foreign-funcall-varargs
"sprintf" (:pointer s :string "%s, %s!") :string "Hello" :string "world" :int))
"Hello, world!")
;;; See DEFCFUN.DOUBLE26.
(deftest funcall.double26
(foreign-funcall "sum_double26"
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double 3.14d0
:double 3.14d0 :double 3.14d0 :double)
81.64d0)
;;; See DEFCFUN.FLOAT26.
(deftest funcall.float26
(foreign-funcall "sum_float26"
:float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float 5.0 :float 5.0 :float 5.0 :float 5.0
:float 5.0 :float)
130.0)
;;; Funcalling a pointer.
(deftest funcall.f-s-p.1
(foreign-funcall-pointer (foreign-symbol-pointer "abs") nil :int -42 :int)
42)
;;;# Namespaces
#-cffi-sys::flat-namespace
(deftest funcall.namespace.1
(values (foreign-funcall ("ns_function" :library libtest) :boolean)
(foreign-funcall ("ns_function" :library libtest2) :boolean))
t nil)
;;;# stdcall
#+(and x86 windows (not cffi-sys::no-stdcall))
(deftest funcall.stdcall.1
(flet ((fun ()
(foreign-funcall ("stdcall_fun@12" :convention :stdcall)
:int 1 :int 2 :int 3 :int)))
(loop repeat 100 do (fun)
finally (return (fun))))
6)
;;; RT: NIL arguments are skipped
(defvar *nil-skipped*)
(define-foreign-type check-nil-skip-type ()
()
(:actual-type :pointer)
(:simple-parser check-nil-skip-type))
(defmethod expand-to-foreign (val (type check-nil-skip-type))
(declare (ignore val))
(setf *nil-skipped* nil)
(null-pointer))
(deftest funcall.nil-skip
(let ((*nil-skipped* t))
(compile nil '(lambda ()
(foreign-funcall "abs" check-nil-skip-type nil)))
*nil-skipped*)
nil)
;;; RT: CLISP returns NIL instead of a null-pointer
(deftest funcall.pointer-not-nil
(not (null (foreign-funcall "strchr" :string "" :int 1 :pointer)))
t)
) ;; #-cffi-sys::no-foreign-funcall

96
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/grovel.lisp Normal file
View file

@ -0,0 +1,96 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; grovel.lisp --- CFFI-Grovel tests.
;;;
;;; Copyright (C) 2014, 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)
(deftest %invoke
(cffi-grovel::invoke "echo" "test")
nil nil 0)
(defun grovel-forms (forms &key (quiet t))
(uiop:with-temporary-file (:stream grovel-stream :pathname grovel-file)
(with-standard-io-syntax
(with-open-stream (*standard-output* grovel-stream)
(let ((*package* (find-package :keyword)))
(mapc #'write forms))))
(let ((lisp-file (let ((*debug-io* (if quiet (make-broadcast-stream) *debug-io*)))
(cffi-grovel:process-grovel-file grovel-file))))
(unwind-protect
(load lisp-file)
(uiop:delete-file-if-exists lisp-file)))))
(defun bug-1395242-helper (enum-type base-type constant-name)
(check-type enum-type (member constantenum cenum))
(check-type base-type string)
(check-type constant-name string)
(let ((enum-name (intern (symbol-name (gensym))))
(base-type-name (intern (symbol-name (gensym)))))
(grovel-forms `((ctype ,base-type-name ,base-type)
(,enum-type (,enum-name :base-type ,base-type-name)
((:value ,constant-name)))))
(cffi:foreign-enum-value enum-name :value)))
(deftest bug-1395242
(labels
((process-expression (expression)
(loop for enum-type in '(constantenum cenum)
always (destructuring-bind (base-type &rest evaluations) expression
(loop for (name expected-value) in evaluations
for actual-value = (bug-1395242-helper enum-type base-type name)
always (or (= expected-value actual-value)
(progn
(format *error-output*
"Test failed for case: ~A, ~A, ~A (expected ~A, actual ~A)~%"
enum-type base-type name expected-value actual-value)
nil)))))))
(every #'process-expression
'(("uint8_t" ("UINT8_MAX" 255) ("INT8_MAX" 127) ("INT8_MIN" 128))
("int8_t" ("INT8_MIN" -128) ("INT8_MAX" 127) ("UINT8_MAX" -1))
("uint16_t" ("UINT16_MAX" 65535) ("INT8_MIN" 65408))
("int16_t" ("INT16_MIN" -32768) ("INT16_MAX" 32767) ("UINT16_MAX" -1))
("uint32_t" ("UINT32_MAX" 4294967295) ("INT8_MIN" 4294967168))
("int32_t" ("INT32_MIN" -2147483648) ("INT32_MAX" 2147483647)))))
t)
(defvar *grovelled-features*)
(deftest grovel-feature
(let ((*grovelled-features* nil))
(grovel-forms `((in-package :cffi-tests)
(include "limits.h")
(feature grovel-test-feature "CHAR_BIT")
(feature :char-bit "CHAR_BIT"
:feature-list *grovelled-features*)
(feature :inexistent-grovel-feature
"INEXISTENT_CFFI_GROVEL_FEATURE"
:feature-list *grovelled-features*)))
(unwind-protect
(values (and (member 'grovel-test-feature *features*) t)
(and (member :char-bit *grovelled-features*) t)
(member :inexistent-grovel-feature *grovelled-features*))
(alexandria:removef *features* 'grovel-test-feature)))
t t nil)

179
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/libfsbv.c Normal file
View file

@ -0,0 +1,179 @@
/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
*
* libfsbv.c --- auxiliary C lib for testing foreign structure by value calls
*
* Copyright (C) 2011, 2015 Liam M. Healy
*
* 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.
*/
#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif
#include <stdio.h>
#include <limits.h>
#include <string.h>
#include <stdlib.h>
#include <stdbool.h>
#include <math.h>
#include <float.h>
/* MSVC doesn't have stdint.h and uses a different syntax for stdcall */
#ifndef _MSC_VER
#include <stdint.h>
#endif
#ifdef WIN32
#ifdef _MSC_VER
#define STDCALL __stdcall
#else
#define STDCALL __attribute__((stdcall))
#endif
#else
#define STDCALL
#endif
struct struct_pair {
int a;
int b;
};
struct struct_pair_double {
struct struct_pair pr;
double dbl;
};
typedef enum {
ONE = 1,
TWO,
THREE,
FOUR,
FORTY_ONE = 41,
FORTY_TWO
} numeros;
int sumpair (struct struct_pair sp);
int enumpair (numeros mynum, struct struct_pair sp);
struct struct_pair doublepair (struct struct_pair dp);
double prodsumpair (struct struct_pair_double spd);
struct struct_pair_double doublepairdouble (struct struct_pair_double pd);
DLLEXPORT
int sumpair (struct struct_pair sp)
{
return sp.a + sp.b;
}
DLLEXPORT
int enumpair (numeros mynum, struct struct_pair sp)
{
if ( mynum == ONE )
{
return sp.a + sp.b;
}
else if ( mynum == TWO )
{
return sp.a + 2*sp.b;
}
else if ( mynum == THREE )
{
return 2*sp.a + sp.b;
}
else if ( mynum == FOUR )
{
return 2*sp.a + 2*sp.b;
}
else
{
return 41*sp.a + 42*sp.b;
}
}
DLLEXPORT
struct struct_pair makepair (bool cond)
{
struct struct_pair ret;
ret.a = -127;
ret.b = cond ? 42 : 43;
return ret;
}
const struct struct_pair static_pair = { 40, 2};
DLLEXPORT
struct struct_pair * returnpairpointer (struct struct_pair ignored)
{
return &static_pair;
}
DLLEXPORT
struct struct_pair doublepair (struct struct_pair dp)
{
struct struct_pair ret;
ret.a = 2*dp.a;
ret.b = 2*dp.b;
return ret;
}
DLLEXPORT
double prodsumpair (struct struct_pair_double pd)
{
return pd.dbl * sumpair(pd.pr);
}
DLLEXPORT
struct struct_pair_double doublepairdouble (struct struct_pair_double pd)
{
struct struct_pair_double ret;
ret.pr = doublepair(pd.pr);
ret.dbl = 2*pd.dbl;
return ret;
}
DLLEXPORT
unsigned long long ullsum (unsigned long long a, unsigned long long b)
{
return a + b;
}
DLLEXPORT
struct struct_pair stringlenpair (char *string, struct struct_pair dp)
{
struct struct_pair ret;
int len = strlen(string);
ret.a = len*dp.a;
ret.b = len*dp.b;
return ret;
}
struct bitfield_struct {
unsigned int b;
};
DLLEXPORT
struct bitfield_struct structbitfield (unsigned int x) {
struct bitfield_struct ret;
ret.b = x;
return ret;
}

985
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/libtest.c Normal file
View file

@ -0,0 +1,985 @@
/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
*
* libtest.c --- auxiliary C lib for testing purposes
*
* 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.
*/
#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif
#include <stdio.h>
#include <limits.h>
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <float.h>
#include <stdbool.h>
#include <stdarg.h>
/* MSVC doesn't have stdint.h and uses a different syntax for stdcall */
#ifndef _MSC_VER
#include <stdint.h>
#endif
#ifdef WIN32
#ifdef _MSC_VER
#define STDCALL __stdcall
#else
#define STDCALL __attribute__((stdcall))
#endif
#else
#define STDCALL
#endif
/*
* Some functions that aren't available on WIN32
*/
DLLEXPORT
float my_sqrtf(float n)
{
return (float) sqrt((double) n);
}
DLLEXPORT
char *my_strdup(const char *str)
{
char *p = malloc(strlen(str) + 1);
strcpy(p, str);
return p;
}
DLLEXPORT
void my_strfree(char *str)
{
free(str);
}
DLLEXPORT
long long my_llabs(long long n)
{
return n < 0 ? -n : n;
}
DLLEXPORT
unsigned long long ullong(unsigned long long n)
{
return n == ULLONG_MAX ? n : 42;
}
/*
* Foreign Globals
*
* (var_int is used in MISC-TYPES.EXPAND.3 as well)
*/
DLLEXPORT char * dll_version = "20120107";
/* TODO: look into signed char vs. unsigned char issue */
DLLEXPORT char var_char = -127;
DLLEXPORT unsigned char var_unsigned_char = 255;
DLLEXPORT short var_short = -32767;
DLLEXPORT unsigned short var_unsigned_short = 65535;
DLLEXPORT int var_int = -32767;
DLLEXPORT unsigned int var_unsigned_int = 65535;
DLLEXPORT long var_long = -2147483647L;
DLLEXPORT unsigned long var_unsigned_long = 4294967295UL;
DLLEXPORT float var_float = 42.0f;
DLLEXPORT double var_double = 42.0;
DLLEXPORT void * var_pointer = NULL;
DLLEXPORT char * var_string = "Hello, foreign world!";
DLLEXPORT long long var_long_long = -9223372036854775807LL;
DLLEXPORT unsigned long long var_unsigned_long_long = 18446744073709551615ULL;
DLLEXPORT float float_max = FLT_MAX;
DLLEXPORT float float_min = FLT_MIN;
DLLEXPORT double double_max = DBL_MAX;
DLLEXPORT double double_min = DBL_MIN;
/*
* Callbacks
*/
DLLEXPORT
int expect_char_sum(char (*f)(char, char))
{
return f('a', 3) == 'd';
}
DLLEXPORT
int expect_unsigned_char_sum(unsigned char (*f)(unsigned char, unsigned char))
{
return f(UCHAR_MAX-1, 1) == UCHAR_MAX;
}
DLLEXPORT
int expect_short_sum(short (*f)(short a, short b))
{
return f(SHRT_MIN+1, -1) == SHRT_MIN;
}
DLLEXPORT
int expect_unsigned_short_sum(unsigned short (*f)(unsigned short,
unsigned short))
{
return f(USHRT_MAX-1, 1) == USHRT_MAX;
}
/* used in MISC-TYPES.EXPAND.4 as well */
DLLEXPORT
int expect_int_sum(int (*f)(int, int))
{
return f(INT_MIN+1, -1) == INT_MIN;
}
DLLEXPORT
int expect_unsigned_int_sum(unsigned int (*f)(unsigned int, unsigned int))
{
return f(UINT_MAX-1, 1) == UINT_MAX;
}
DLLEXPORT
int expect_long_sum(long (*f)(long, long))
{
return f(LONG_MIN+1, -1) == LONG_MIN;
}
DLLEXPORT
int expect_unsigned_long_sum(unsigned long (*f)(unsigned long, unsigned long))
{
return f(ULONG_MAX-1, 1) == ULONG_MAX;
}
DLLEXPORT
int expect_long_long_sum(long long (*f)(long long, long long))
{
return f(LLONG_MIN+1, -1) == LLONG_MIN;
}
DLLEXPORT
int expect_unsigned_long_long_sum (unsigned long long
(*f)(unsigned long long, unsigned long long))
{
return f(ULLONG_MAX-1, 1) == ULLONG_MAX;
}
DLLEXPORT
int expect_float_sum(float (*f)(float, float))
{
/*printf("\n>>> FLOAT: %f <<<\n", f(20.0f, 22.0f));*/
return f(20.0f, 22.0f) == 42.0f;
}
DLLEXPORT
int expect_double_sum(double (*f)(double, double))
{
/*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
return f(-20.0, -22.0) == -42.0;
}
DLLEXPORT
int expect_long_double_sum(long double (*f)(long double, long double))
{
/*printf("\n>>> DOUBLE: %f<<<\n", f(-20.0, -22.0));*/
return f(-20.0, -22.0) == -42.0;
}
DLLEXPORT
int expect_pointer_sum(void* (*f)(void*, int))
{
return f(NULL, 0xDEAD) == (void *) 0xDEAD;
}
DLLEXPORT
int expect_strcat(char* (*f)(char*, char*))
{
char *ret = f("Hello, ", "C world!");
int res = strcmp(ret, "Hello, C world!") == 0;
/* commented out as a quick fix on platforms that don't
foreign allocate in C malloc space. */
/*free(ret);*/ /* is this allowed? */
return res;
}
DLLEXPORT
void pass_int_ref(void (*f)(int*))
{
int x = 1984;
f(&x);
}
/*
* Enums
*/
typedef enum {
ONE = 1,
TWO,
THREE,
FOUR,
FORTY_ONE = 41,
FORTY_TWO
} numeros;
DLLEXPORT
int check_enums(numeros one, numeros two, numeros three, numeros four,
numeros forty_one, numeros forty_two)
{
if (one == ONE && two == TWO && three == THREE && four == FOUR &&
forty_one == FORTY_ONE && forty_two == FORTY_TWO)
return 1;
return 0;
}
typedef enum { FALSE, TRUE } another_boolean;
DLLEXPORT
another_boolean return_enum(int x)
{
if (x == 0)
return FALSE;
else
return TRUE;
}
/*
* Booleans
*/
DLLEXPORT
int equalequal(int a, unsigned int b)
{
return ((unsigned int) a) == b;
}
DLLEXPORT
char bool_and(unsigned char a, char b)
{
return a && b;
}
DLLEXPORT
unsigned long bool_xor(long a, unsigned long b)
{
return (a && !b) || (!a && b);
}
DLLEXPORT
unsigned sizeof_bool(void)
{
return (unsigned) sizeof(_Bool);
}
DLLEXPORT
unsigned bool_to_unsigned(_Bool b)
{
return (unsigned) b;
}
DLLEXPORT
_Bool unsigned_to_bool(unsigned u)
{
return (_Bool) u;
}
/*
* Test struct alignment issues. These comments assume the x86 gABI.
* Hopefully these tests will spot alignment issues in others archs
* too.
*/
/*
* STRUCT.ALIGNMENT.1
*/
struct s_ch {
char a_char;
};
/* This struct's size should be 2 bytes */
struct s_s_ch {
char another_char;
struct s_ch a_s_ch;
};
DLLEXPORT
struct s_s_ch the_s_s_ch = { 2, { 1 } };
/*
* STRUCT.ALIGNMENT.2
*/
/* This one should be alignment should be the same as short's alignment. */
struct s_short {
char a_char;
char another_char;
short a_short;
};
struct s_s_short {
char yet_another_char;
struct s_short a_s_short; /* so this should be 2-byte aligned */
}; /* size: 6 bytes */
DLLEXPORT
struct s_s_short the_s_s_short = { 4, { 1, 2, 3 } };
/*
* STRUCT.ALIGNMENT.3
*/
/* This test will, among other things, check for the existence tail padding. */
struct s_double {
char a_char; /* 1 byte */
/* padding: 3 bytes */
double a_double; /* 8 bytes */
char another_char; /* 1 byte */
/* padding: 3 bytes */
}; /* total size: 16 bytes */
struct s_s_double {
char yet_another_char; /* 1 byte */
/* 3 bytes padding */
struct s_double a_s_double; /* 16 bytes */
short a_short; /* 2 byte */
/* 2 bytes padding */
}; /* total size: 24 bytes */
DLLEXPORT
struct s_s_double the_s_s_double = { 4, { 1, 2.0, 3 }, 5 };
/*
* STRUCT.ALIGNMENT.4
*/
struct s_s_s_double {
short another_short; /* 2 bytes */
/* 2 bytes padding */
struct s_s_double a_s_s_double; /* 24 bytes */
char last_char; /* 1 byte */
/* 3 bytes padding */
}; /* total size: 32 */
DLLEXPORT
struct s_s_s_double the_s_s_s_double = { 6, { 4, { 1, 2.0, 3 }, 5 }, 7 };
/*
* STRUCT.ALIGNMENT.5
*/
/* MacOSX ABI says: "The embedding alignment of the first element in a data
structure is equal to the element's natural alignment." and "For subsequent
elements that have a natural alignment greater than 4 bytes, the embedding
alignment is 4, unless the element is a vector." */
/* note: these rules will apply to the structure itself. So, unless it is
the first element of another structure, its alignment will be 4. */
/* the following offsets and sizes are specific to darwin/ppc32 */
struct s_double2 {
double a_double; /* 8 bytes (alignment 8) */
short a_short; /* 2 bytes */
/* 6 bytes padding */
}; /* total size: 16 */
struct s_s_double2 {
char a_char; /* 1 byte */
/* 3 bytes padding */
struct s_double2 a_s_double2; /* 16 bytes, alignment 4 */
short another_short; /* 2 bytes */
/* 2 bytes padding */
}; /* total size: 24 bytes */
/* alignment: 4 */
DLLEXPORT
struct s_s_double2 the_s_s_double2 = { 3, { 1.0, 2 }, 4 };
/*
* STRUCT.ALIGNMENT.6
*/
/* Same as STRUCT.ALIGNMENT.5 but with long long. */
struct s_long_long {
long long a_long_long; /* 8 bytes (alignment 8) */
short a_short; /* 2 bytes */
/* 6 bytes padding */
}; /* total size: 16 */
struct s_s_long_long {
char a_char; /* 1 byte */
/* 3 bytes padding */
struct s_long_long a_s_long_long; /* 16 bytes, alignment 4 */
short a_short; /* 2 bytes */
/* 2 bytes padding */
}; /* total size: 24 bytes */
/* alignment: 4 */
DLLEXPORT
struct s_s_long_long the_s_s_long_long = { 3, { 1, 2 }, 4 };
/*
* STRUCT.ALIGNMENT.7
*/
/* Another test for Darwin's PPC32 ABI. */
struct s_s_double3 {
struct s_double2 a_s_double2; /* 16 bytes, alignment 8*/
short another_short; /* 2 bytes */
/* 6 bytes padding */
}; /* total size: 24 */
struct s_s_s_double3 {
struct s_s_double3 a_s_s_double3; /* 24 bytes */
char a_char; /* 1 byte */
/* 7 bytes padding */
}; /* total size: 32 */
DLLEXPORT
struct s_s_s_double3 the_s_s_s_double3 = { { { 1.0, 2 }, 3 }, 4 };
/*
* STRUCT.ALIGNMENT.8
*/
/* Same as STRUCT.ALIGNMENT.[56] but with unsigned long long. */
struct s_unsigned_long_long {
unsigned long long an_unsigned_long_long; /* 8 bytes (alignment 8) */
short a_short; /* 2 bytes */
/* 6 bytes padding */
}; /* total size: 16 */
struct s_s_unsigned_long_long {
char a_char; /* 1 byte */
/* 3 bytes padding */
struct s_unsigned_long_long a_s_unsigned_long_long; /* 16 bytes, align 4 */
short a_short; /* 2 bytes */
/* 2 bytes padding */
}; /* total size: 24 bytes */
/* alignment: 4 */
DLLEXPORT
struct s_s_unsigned_long_long the_s_s_unsigned_long_long = { 3, { 1, 2 }, 4 };
/* STRUCT.ALIGNMENT.x */
/* commented this test out because this is not standard C
and MSVC++ (or some versions of it at least) won't compile it. */
/*
struct empty_struct {};
struct with_empty_struct {
struct empty_struct foo;
int an_int;
};
DLLEXPORT
struct with_empty_struct the_with_empty_struct = { {}, 42 };
*/
/*
* STRUCT-VALUES.*
*/
struct pair { int a, b; };
DLLEXPORT
int pair_sum(struct pair p)
{
return p.a + p.b;
}
DLLEXPORT
int pair_pointer_sum(struct pair *p)
{
return p->a + p->b;
}
DLLEXPORT
struct pair make_pair(int a, int b)
{
return (struct pair) { a, b };
}
DLLEXPORT
struct pair *alloc_pair(int a, int b)
{
struct pair *p = malloc(sizeof(struct pair));
p->a = a;
p->b = b;
return p;
}
struct pair_plus_one {
struct pair p;
int c;
};
DLLEXPORT
int pair_plus_one_sum(struct pair_plus_one p)
{
return p.p.a + p.p.b + p.c;
}
DLLEXPORT
int pair_plus_one_pointer_sum(struct pair_plus_one *p)
{
return p->p.a + p->p.b + p->c;
}
DLLEXPORT
struct pair_plus_one make_pair_plus_one(int a, int b, int c)
{
return (struct pair_plus_one) { { a, b }, c };
}
DLLEXPORT
struct pair_plus_one *alloc_pair_plus_one(int a, int b, int c)
{
struct pair_plus_one *p = malloc(sizeof(struct pair_plus_one));
p->p.a = a;
p->p.b = b;
p->c = c;
return p;
}
/*
* DEFCFUN.NOARGS and DEFCFUN.NOOP
*/
DLLEXPORT
int noargs()
{
return 42;
}
DLLEXPORT
void noop()
{
return;
}
/*
* DEFCFUN.BFF.1
*
* (let ((rettype (find-type :long))
* (arg-types (n-random-types-no-ll 127)))
* (c-function rettype arg-types)
* (gen-function-test rettype arg-types))
*/
DLLEXPORT long sum_127_no_ll
(long a1, unsigned long a2, short a3, unsigned short a4, float a5,
double a6, unsigned long a7, float a8, unsigned char a9, unsigned
short a10, short a11, unsigned long a12, double a13, long a14,
unsigned int a15, void* a16, unsigned int a17, unsigned short a18,
long a19, float a20, void* a21, float a22, int a23, int a24, unsigned
short a25, long a26, long a27, double a28, unsigned char a29, unsigned
int a30, unsigned int a31, int a32, unsigned short a33, unsigned int
a34, void* a35, double a36, double a37, long a38, short a39, unsigned
short a40, long a41, char a42, long a43, unsigned short a44, void*
a45, int a46, unsigned int a47, double a48, unsigned char a49,
unsigned char a50, float a51, int a52, unsigned short a53, double a54,
short a55, unsigned char a56, unsigned long a57, float a58, float a59,
float a60, void* a61, void* a62, unsigned int a63, unsigned long a64,
char a65, short a66, unsigned short a67, unsigned long a68, void* a69,
float a70, double a71, long a72, unsigned long a73, short a74,
unsigned int a75, unsigned short a76, int a77, unsigned short a78,
char a79, double a80, short a81, unsigned char a82, float a83, char
a84, int a85, double a86, unsigned char a87, int a88, unsigned long
a89, double a90, short a91, short a92, unsigned int a93, unsigned char
a94, float a95, long a96, float a97, long a98, long a99, int a100, int
a101, unsigned int a102, char a103, char a104, unsigned short a105,
unsigned int a106, unsigned short a107, unsigned short a108, int a109,
long a110, char a111, double a112, unsigned int a113, char a114, short
a115, unsigned long a116, unsigned int a117, short a118, unsigned char
a119, float a120, void* a121, double a122, int a123, long a124, char
a125, unsigned short a126, float a127)
{
return (long) a1 + a2 + a3 + a4 + ((long) a5) + ((long) a6) + a7 +
((long) a8) + a9 + a10 + a11 + a12 + ((long) a13) + a14 + a15 +
((intptr_t) a16) + a17 + a18 + a19 + ((long) a20) +
((intptr_t) a21) + ((long) a22) + a23 + a24 + a25 + a26 + a27 +
((long) a28) + a29 + a30 + a31 + a32 + a33 + a34 + ((intptr_t) a35) +
((long) a36) + ((long) a37) + a38 + a39 + a40 + a41 + a42 + a43 + a44 +
((intptr_t) a45) + a46 + a47 + ((long) a48) + a49 + a50 +
((long) a51) + a52 + a53 + ((long) a54) + a55 + a56 + a57 + ((long) a58) +
((long) a59) + ((long) a60) + ((intptr_t) a61) +
((intptr_t) a62) + a63 + a64 + a65 + a66 + a67 + a68 +
((intptr_t) a69) + ((long) a70) + ((long) a71) + a72 + a73 + a74 +
a75 + a76 + a77 + a78 + a79 + ((long) a80) + a81 + a82 + ((long) a83) +
a84 + a85 + ((long) a86) + a87 + a88 + a89 + ((long) a90) + a91 + a92 +
a93 + a94 + ((long) a95) + a96 + ((long) a97) + a98 + a99 + a100 + a101 +
a102 + a103 + a104 + a105 + a106 + a107 + a108 + a109 + a110 + a111 +
((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 +
((long) a120) + ((intptr_t) a121) + ((long) a122) + a123 + a124 +
a125 + a126 + ((long) a127);
}
/*
* DEFCFUN.BFF.2
*
* (let ((rettype (find-type :long-long))
* (arg-types (n-random-types 127)))
* (c-function rettype arg-types)
* (gen-function-test rettype arg-types))
*/
DLLEXPORT long long sum_127
(void* a1, void* a2, float a3, unsigned long a4, void* a5, long long
a6, double a7, double a8, unsigned short a9, int a10, long long a11,
long a12, short a13, unsigned int a14, long a15, unsigned char a16,
int a17, double a18, short a19, short a20, long long a21, unsigned
int a22, unsigned short a23, short a24, void* a25, short a26,
unsigned short a27, unsigned short a28, int a29, long long a30,
void* a31, int a32, unsigned long a33, unsigned long a34, void* a35,
unsigned long long a36, float a37, int a38, short a39, void* a40,
unsigned long long a41, long long a42, unsigned long a43, unsigned
long a44, unsigned long long a45, unsigned long a46, char a47,
double a48, long a49, unsigned int a50, int a51, short a52, void*
a53, long a54, unsigned long long a55, int a56, unsigned short a57,
unsigned long long a58, float a59, void* a60, float a61, unsigned
short a62, unsigned long a63, float a64, unsigned int a65, unsigned
long long a66, void* a67, double a68, unsigned long long a69, double
a70, double a71, long long a72, void* a73, unsigned short a74, long
a75, void* a76, short a77, double a78, long a79, unsigned char a80,
void* a81, unsigned char a82, long a83, double a84, void* a85, int
a86, double a87, unsigned char a88, double a89, short a90, long a91,
int a92, long a93, double a94, unsigned short a95, unsigned int a96,
int a97, char a98, long long a99, double a100, float a101, unsigned
long a102, short a103, void* a104, float a105, long long a106, int
a107, long long a108, long long a109, double a110, unsigned long
long a111, double a112, unsigned long a113, char a114, char a115,
unsigned long a116, short a117, unsigned char a118, unsigned char
a119, int a120, int a121, float a122, unsigned char a123, unsigned
char a124, double a125, unsigned long long a126, char a127)
{
return (long long) ((intptr_t) a1) + ((intptr_t) a2) + ((long) a3) +
a4 + ((intptr_t) a5) + a6 + ((long) a7) + ((long) a8) + a9 + a10 +
a11 + a12 + a13 + a14 + a15 + a16 + a17 + ((long) a18) + a19 + a20 +
a21 + a22 + a23 + a24 + ((intptr_t) a25) + a26 + a27 + a28 + a29 +
a30 + ((intptr_t) a31) + a32 + a33 + a34 + ((intptr_t) a35) +
a36 + ((long) a37) + a38 + a39 + ((intptr_t) a40) + a41 + a42 + a43 +
a44 + a45 + a46 + a47 + ((long) a48) + a49 + a50 + a51 + a52 +
((intptr_t) a53) + a54 + a55 + a56 + a57 + a58 + ((long) a59) +
((intptr_t) a60) + ((long) a61) + a62 + a63 + ((long) a64) + a65 + a66
+ ((intptr_t) a67) + ((long) a68) + a69 + ((long) a70) + ((long) a71) +
a72 + ((intptr_t) a73) + a74 + a75 + ((intptr_t) a76) + a77 +
((long) a78) + a79 + a80 + ((intptr_t) a81) + a82 + a83 + ((long) a84)
+ ((intptr_t) a85) + a86 + ((long) a87) + a88 + ((long) a89) + a90 +
a91 + a92 + a93 + ((long) a94) + a95 + a96 + a97 + a98 + a99 +
((long) a100) + ((long) a101) + a102 + a103 + ((intptr_t) a104) +
((long) a105) + a106 + a107 + a108 + a109 + ((long) a110) + a111 +
((long) a112) + a113 + a114 + a115 + a116 + a117 + a118 + a119 + a120 +
a121 + ((long) a122) + a123 + a124 + ((long) a125) + a126 + a127;
}
/*
* CALLBACKS.BFF.1 (cb-test :no-long-long t)
*/
DLLEXPORT long call_sum_127_no_ll
(long (*func)
(unsigned long, void*, long, double, unsigned long, float, float,
int, unsigned int, double, double, double, void*, unsigned short,
unsigned short, void*, long, long, int, short, unsigned short,
unsigned short, char, long, void*, void*, char, unsigned char,
unsigned long, short, int, int, unsigned char, short, long, long,
void*, unsigned short, char, double, unsigned short, void*, short,
unsigned long, unsigned short, float, unsigned char, short, float,
short, char, unsigned long, unsigned long, char, float, long, void*,
short, float, unsigned int, float, unsigned int, double, unsigned int,
unsigned char, int, long, char, short, double, int, void*, char,
unsigned short, void*, unsigned short, void*, unsigned long, double,
void*, long, float, unsigned short, unsigned short, void*, float, int,
unsigned int, double, float, long, void*, unsigned short, float,
unsigned char, unsigned char, float, unsigned int, float, unsigned
short, double, unsigned short, unsigned long, unsigned int, unsigned
long, void*, unsigned char, char, char, unsigned short, unsigned long,
float, short, void*, long, unsigned short, short, double, short, int,
char, unsigned long, long, int, void*, double, unsigned char))
{
return
func(948223085, (void *) 803308438, -465723152, 20385,
219679466, -10035, 13915, -1193455756, 1265303699, 27935, -18478,
-10508, (void *) 215389089, 55561, 55472, (void *) 146070433,
-1040819989, -17851453, -1622662247, -19473, 20837, 30216, 79,
986800400, (void *) 390281604, (void *) 1178532858, 19, 117,
78337699, -5718, -991300738, 872160910, 184, 926, -1487245383,
1633973783, (void *) 33738609, 53985, -116, 31645, 27196, (void *)
145569903, -6960, 17252220, 47404, -10491, 88, -30438, -21212,
-1982, -16, 1175270, 7949380, -121, 8559, -432968526, (void *)
293455312, 11894, -8394, 142421516, -25758, 3422998, 4004,
15758212, 198, -1071899743, -1284904617, -11, -17219, -30039,
311589092, (void *) 541468577, 123, 63517, (void *) 1252504506,
39368, (void *) 10057868, 134781408, -7143, (void *) 72825877,
-1190798667, -30862, 63757, 14965, (void *) 802391252, 22008,
-517289619, 806091099, 1125, 451, -498145176, (void *) 55960931,
15379, 4629, 184, 254, 22532, 465856451, -1669, 49416, -16546,
2983, 4337541, 65292495, 39253529, (void *) 669025, 211, 85, -19,
24298, 65358, 16776, -29957, (void *) 124311, -163231228, 2610,
-7806, 26434, -21913, -753615541, 120, 358697932, -1198889034,
-2131350926, (void *) 3749492036, -13413, 17);
}
/*
* CALLBACKS.BFF.2 (cb-test)
*/
DLLEXPORT long long call_sum_127
(long long (*func)
(short, char, void*, float, long, double, unsigned long long,
unsigned short, unsigned char, char, char, unsigned short, unsigned
long long, unsigned short, long long, unsigned short, unsigned long
long, unsigned char, unsigned char, unsigned long long, long long,
char, float, unsigned int, float, float, unsigned int, float, char,
unsigned char, long, long long, unsigned char, double, long,
double, unsigned int, unsigned short, long long, unsigned int, int,
unsigned long long, long, short, unsigned int, unsigned int,
unsigned long long, unsigned int, long, void*, unsigned char, char,
long long, unsigned short, unsigned int, float, unsigned char,
unsigned long, long long, float, long, float, int, float, unsigned
short, unsigned long long, short, unsigned long, long, char,
unsigned short, long long, short, double, void*, unsigned int,
char, unsigned int, void*, void*, unsigned char, void*, unsigned
short, unsigned char, long, void*, char, long, unsigned short,
unsigned char, double, unsigned long long, unsigned short, unsigned
short, unsigned int, long, char, long, char, short, unsigned short,
unsigned long, unsigned long, short, long long, long long, long
long, double, unsigned short, unsigned char, short, unsigned char,
long, long long, unsigned long long, unsigned int, unsigned long,
unsigned char, long long, unsigned char, unsigned long long,
double, unsigned char, long long, unsigned char, char, long long))
{
return
func(-8573, 14, (void *) 832601021, -32334, -1532040888,
-18478, 2793023182591311826, 2740, 230, 103, 97, 13121,
5112369026351511084, 7763, -8134147951003417418, 34348,
5776613699556468853, 19, 122, 1431603726926527625,
439503521880490337, -112, -21557, 1578969190, -22008, -4953,
2127745975, -7262, -6, 180, 226352974, -3928775366167459219, 134,
-17730, -1175042526, 23868, 3494181009, 57364,
3134876875147518682, 104531655, -1286882727, 803577887579693487,
1349268803, 24912, 3313099419, 3907347884, 1738833249233805034,
2794230885, 1008818752, (void *) 1820044575, 189, 61,
-931654560961745071, 57531, 3096859985, 10405, 220, 3631311224,
-8531370353478907668, 31258, 678896693, -32150, -1869057813,
-19877, 62841, 4161660185772906873, -23869, 4016251006, 610353435,
105, 47315, -1051054492535331660, 6846, -15163, (void *)
736672359, 2123928476, -122, 3859258652, (void *) 3923394833,
(void *) 1265031970, 161, (void *) 1993867800, 55056, 122,
1562112760, (void *) 866615125, -79, -1261399547, 31737, 254,
-31279, 5462649659172897980, 5202, 7644, 174224940, -337854382,
-45, -583502442, -37, -13266, 24520, 2198606699, 2890453969,
-8282, -2295716637858246075, -1905178488651598878,
-6384652209316714643, 14841, 35443, 132, 15524, 187, 2138878229,
-5153032566879951000, 9056545530140684207, 4124632010, 276167701,
56, -2307310370663738730, 66, 9113015627153789746, -9618, 167,
755753399701306200, 119, -28, -990561962725435433);
}
/*
* CALLBACKS.DOUBLE26
*/
DLLEXPORT double call_double26
(double (*f)(double, double, double, double, double, double, double, double,
double, double, double, double, double, double, double, double,
double, double, double, double, double, double, double, double,
double, double))
{
return f(3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14, 3.14,
3.14, 3.14, 3.14, 3.14);
}
/*
* DEFCFUN.DOUBLE26 and FUNCALL.DOUBLE26
*/
DLLEXPORT
double sum_double26(double a1, double a2, double a3, double a4, double a5,
double a6, double a7, double a8, double a9, double a10,
double a11, double a12, double a13, double a14, double a15,
double a16, double a17, double a18, double a19, double a20,
double a21, double a22, double a23, double a24, double a25,
double a26)
{
return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
a26;
}
/*
* DEFCFUN.VARARGS.NOSTDLIB and FUNCALL.VARARGS.NOSTDLIB
*/
DLLEXPORT
double sum_double_arbitrary(int n, ...)
{
va_list ap;
double sum = 0;
va_start(ap, n);
for(int j=0; j<n; j++)
sum += va_arg(ap, double);
va_end(ap);
return sum;
}
/*
* CALLBACKS.FLOAT26
*/
DLLEXPORT float call_float26
(float (*f)(float, float, float, float, float, float, float, float,
float, float, float, float, float, float, float, float,
float, float, float, float, float, float, float, float,
float, float))
{
return f(5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0,
5.0, 5.0, 5.0, 5.0);
}
/*
* DEFCFUN.FLOAT26 and FUNCALL.FLOAT26
*/
DLLEXPORT
float sum_float26(float a1, float a2, float a3, float a4, float a5,
float a6, float a7, float a8, float a9, float a10,
float a11, float a12, float a13, float a14, float a15,
float a16, float a17, float a18, float a19, float a20,
float a21, float a22, float a23, float a24, float a25,
float a26)
{
return a1 + a2 + a3 + a4 + a5 + a6 + a7 + a8 + a9 + a10 + a11 + a12 + a13 +
a14 + a15 + a16 + a17 + a18 + a19 + a20 + a21 + a22 + a23 + a24 + a25 +
a26;
}
/*
* Symbol case.
*/
DLLEXPORT int UPPERCASEINT1 = 12345;
DLLEXPORT int UPPER_CASE_INT1 = 23456;
DLLEXPORT int MiXeDCaSeInT1 = 34567;
DLLEXPORT int MiXeD_CaSe_InT1 = 45678;
DLLEXPORT int UPPERCASEINT2 = 12345;
DLLEXPORT int UPPER_CASE_INT2 = 23456;
DLLEXPORT int MiXeDCaSeInT2 = 34567;
DLLEXPORT int MiXeD_CaSe_InT2 = 45678;
DLLEXPORT int UPPERCASEINT3 = 12345;
DLLEXPORT int UPPER_CASE_INT3 = 23456;
DLLEXPORT int MiXeDCaSeInT3 = 34567;
DLLEXPORT int MiXeD_CaSe_InT3 = 45678;
/*
* FOREIGN-SYMBOL-POINTER.1
*/
DLLEXPORT int compare_against_abs(intptr_t p)
{
return p == (intptr_t) abs;
}
/*
* FOREIGN-SYMBOL-POINTER.2
*/
DLLEXPORT void xpto_fun() {}
DLLEXPORT
int compare_against_xpto_fun(intptr_t p)
{
return p == (intptr_t) xpto_fun;
}
/*
* [DEFCFUN|FUNCALL].NAMESPACE.1
*/
DLLEXPORT
int ns_function()
{
return 1;
}
/*
* FOREIGN-GLOBALS.NAMESPACE.*
*/
DLLEXPORT int ns_var = 1;
/*
* DEFCFUN.STDCALL.1
*/
DLLEXPORT
int STDCALL stdcall_fun(int a, int b, int c)
{
return a + b + c;
}
/*
* CALLBACKS.STDCALL.1
*/
DLLEXPORT
int call_stdcall_fun(int (STDCALL *f)(int, int, int))
{
int a = 42;
f(1, 2, 3);
return a;
}
/* Unlike the one above, this commented test below actually
* works. But, alas, it doesn't compile with -std=c99. */
/*
DLLEXPORT
int call_stdcall_fun(int __attribute__((stdcall)) (*f)(int, int, int))
{
asm("pushl $42");
register int ebx asm("%ebx");
f(1, 2, 3);
asm("popl %ebx");
return ebx;
}
*/
/* vim: ts=4 et
*/

50
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/libtest2.c Normal file
View file

@ -0,0 +1,50 @@
/* -*- Mode: C; tab-width: 4; indent-tabs-mode: nil -*-
*
* libtest2.c --- auxiliary C lib for testing purposes
*
* Copyright (C) 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.
*/
#ifdef WIN32
#define DLLEXPORT __declspec(dllexport)
#else
#define DLLEXPORT
#endif
/*
* [DEFCFUN|FOREIGN].NAMESPACE.1
*/
DLLEXPORT int ns_function()
{
return 0;
}
/*
* FOREIGN-GLOBALS.NAMESPACE.*
*/
DLLEXPORT int ns_var = 0;
/* vim: ts=4 et
*/

657
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/memory.lisp Normal file
View file

@ -0,0 +1,657 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; memory.lisp --- Tests for memory referencing.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; 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)
(deftest deref.char
(with-foreign-object (p :char)
(setf (mem-ref p :char) -127)
(mem-ref p :char))
-127)
(deftest deref.unsigned-char
(with-foreign-object (p :unsigned-char)
(setf (mem-ref p :unsigned-char) 255)
(mem-ref p :unsigned-char))
255)
(deftest deref.short
(with-foreign-object (p :short)
(setf (mem-ref p :short) -32767)
(mem-ref p :short))
-32767)
(deftest deref.unsigned-short
(with-foreign-object (p :unsigned-short)
(setf (mem-ref p :unsigned-short) 65535)
(mem-ref p :unsigned-short))
65535)
(deftest deref.int
(with-foreign-object (p :int)
(setf (mem-ref p :int) -131072)
(mem-ref p :int))
-131072)
(deftest deref.unsigned-int
(with-foreign-object (p :unsigned-int)
(setf (mem-ref p :unsigned-int) 262144)
(mem-ref p :unsigned-int))
262144)
(deftest deref.long
(with-foreign-object (p :long)
(setf (mem-ref p :long) -536870911)
(mem-ref p :long))
-536870911)
(deftest deref.unsigned-long
(with-foreign-object (p :unsigned-long)
(setf (mem-ref p :unsigned-long) 536870912)
(mem-ref p :unsigned-long))
536870912)
#+(and darwin openmcl)
(pushnew 'deref.long-long rt::*expected-failures*)
(deftest deref.long-long
(with-foreign-object (p :long-long)
(setf (mem-ref p :long-long) -9223372036854775807)
(mem-ref p :long-long))
-9223372036854775807)
(deftest deref.unsigned-long-long
(with-foreign-object (p :unsigned-long-long)
(setf (mem-ref p :unsigned-long-long) 18446744073709551615)
(mem-ref p :unsigned-long-long))
18446744073709551615)
(deftest deref.float.1
(with-foreign-object (p :float)
(setf (mem-ref p :float) 0.0)
(mem-ref p :float))
0.0)
(deftest deref.float.2
(with-foreign-object (p :float)
(setf (mem-ref p :float) *float-max*)
(mem-ref p :float))
#.*float-max*)
(deftest deref.float.3
(with-foreign-object (p :float)
(setf (mem-ref p :float) *float-min*)
(mem-ref p :float))
#.*float-min*)
(deftest deref.double.1
(with-foreign-object (p :double)
(setf (mem-ref p :double) 0.0d0)
(mem-ref p :double))
0.0d0)
(deftest deref.double.2
(with-foreign-object (p :double)
(setf (mem-ref p :double) *double-max*)
(mem-ref p :double))
#.*double-max*)
(deftest deref.double.3
(with-foreign-object (p :double)
(setf (mem-ref p :double) *double-min*)
(mem-ref p :double))
#.*double-min*)
;;; TODO: use something like *DOUBLE-MIN/MAX* above once we actually
;;; have an available lisp that supports long double.
;#-cffi-sys::no-long-float
#+(and scl long-double)
(progn
(deftest deref.long-double.1
(with-foreign-object (p :long-double)
(setf (mem-ref p :long-double) 0.0l0)
(mem-ref p :long-double))
0.0l0)
(deftest deref.long-double.2
(with-foreign-object (p :long-double)
(setf (mem-ref p :long-double) most-positive-long-float)
(mem-ref p :long-double))
#.most-positive-long-float)
(deftest deref.long-double.3
(with-foreign-object (p :long-double)
(setf (mem-ref p :long-double) least-positive-long-float)
(mem-ref p :long-double))
#.least-positive-long-float))
;;; make sure the lisp doesn't convert NULL to NIL
(deftest deref.pointer.null
(with-foreign-object (p :pointer)
(setf (mem-ref p :pointer) (null-pointer))
(null-pointer-p (mem-ref p :pointer)))
t)
;;; regression test. lisp-string-to-foreign should handle empty strings
(deftest lisp-string-to-foreign.empty
(with-foreign-pointer (str 2)
(setf (mem-ref str :unsigned-char) 42)
(lisp-string-to-foreign "" str 1)
(mem-ref str :unsigned-char))
0)
;;; regression test. with-foreign-pointer shouldn't evaluate
;;; the size argument twice.
(deftest with-foreign-pointer.evalx2
(let ((count 0))
(with-foreign-pointer (x (incf count) size-var)
(values count size-var)))
1 1)
(defconstant +two+ 2)
;;; regression test. cffi-allegro's with-foreign-pointer wasn't
;;; handling constants properly.
(deftest with-foreign-pointer.constant-size
(with-foreign-pointer (p +two+ size)
size)
2)
(deftest mem-ref.left-to-right
(let ((i 0))
(with-foreign-object (p :char 3)
(setf (mem-ref p :char 0) 66 (mem-ref p :char 1) 92)
(setf (mem-ref p :char (incf i)) (incf i))
(values (mem-ref p :char 0) (mem-ref p :char 1) i)))
66 2 2)
;;; This needs to be in a real function for at least Allegro CL or the
;;; compiler macro on %MEM-REF is not expanded and the test doesn't
;;; actually test anything!
(defun %mem-ref-left-to-right ()
(let ((result nil))
(with-foreign-object (p :char)
(%mem-set 42 p :char)
(%mem-ref (progn (push 1 result) p) :char (progn (push 2 result) 0))
(nreverse result))))
;;; Test left-to-right evaluation of the arguments to %MEM-REF when
;;; optimized by the compiler macro.
(deftest %mem-ref.left-to-right
(%mem-ref-left-to-right)
(1 2))
;;; This needs to be in a top-level function for at least Allegro CL
;;; or the compiler macro on %MEM-SET is not expanded and the test
;;; doesn't actually test anything!
(defun %mem-set-left-to-right ()
(let ((result nil))
(with-foreign-object (p :char)
(%mem-set (progn (push 1 result) 0)
(progn (push 2 result) p)
:char
(progn (push 3 result) 0))
(nreverse result))))
;;; Test left-to-right evaluation of the arguments to %MEM-SET when
;;; optimized by the compiler macro.
(deftest %mem-set.left-to-right
(%mem-set-left-to-right)
(1 2 3))
;; regression test. mem-aref's setf expansion evaluated its type argument twice.
(deftest mem-aref.eval-type-x2
(let ((count 0))
(with-foreign-pointer (p 1)
(setf (mem-aref p (progn (incf count) :char) 0) 127))
count)
1)
(deftest mem-aref.left-to-right
(let ((count -1))
(with-foreign-pointer (p 2)
(values
(setf (mem-aref p (progn (incf count) :char) (incf count)) (incf count))
(setq count -1)
(mem-aref (progn (incf count) p) :char (incf count))
count)))
2 -1 2 1)
;; regression tests. nested mem-ref's and mem-aref's had bogus getters
(deftest mem-ref.nested
(with-foreign-object (p :pointer)
(with-foreign-object (i :int)
(setf (mem-ref p :pointer) i)
(setf (mem-ref i :int) 42)
(setf (mem-ref (mem-ref p :pointer) :int) 1984)
(mem-ref i :int)))
1984)
(deftest mem-aref.nested
(with-foreign-object (p :pointer)
(with-foreign-object (i :int 2)
(setf (mem-aref p :pointer 0) i)
(setf (mem-aref i :int 1) 42)
(setf (mem-aref (mem-ref p :pointer 0) :int 1) 1984)
(mem-aref i :int 1)))
1984)
(cffi:defcstruct mem-aref.bare-struct
(a :uint8))
;;; regression test: although mem-aref was dealing with bare struct
;;; types as though they were pointers, it wasn't calculating the
;;; proper offsets. The offsets for bare structs types should be
;;; calculated as aggregate types.
(deftest mem-aref.bare-struct
(with-foreign-object (a 'mem-aref.bare-struct 2)
(eql (- (pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 1))
(pointer-address (cffi:mem-aref a 'mem-aref.bare-struct 0)))
(foreign-type-size '(:struct mem-aref.bare-struct))))
t)
;;; regression tests. dereferencing an aggregate type. dereferencing a
;;; struct should return a pointer to the struct itself, not return the
;;; first 4 bytes (or whatever the size of :pointer is) as a pointer.
;;;
;;; This important for accessing an array of structs, which is
;;; what the deref.array-of-aggregates test does.
(defcstruct some-struct (x :int))
(deftest deref.aggregate
(with-foreign-object (s 'some-struct)
(pointer-eq s (mem-ref s 'some-struct)))
t)
(deftest deref.array-of-aggregates
(with-foreign-object (arr 'some-struct 3)
(loop for i below 3
do (setf (foreign-slot-value (mem-aref arr 'some-struct i)
'some-struct 'x)
112))
(loop for i below 3
collect (foreign-slot-value (mem-aref arr 'some-struct i)
'some-struct 'x)))
(112 112 112))
;;; pointer operations
(deftest pointer.1
(pointer-address (make-pointer 42))
42)
;;; I suppose this test is not very good. --luis
(deftest pointer.2
(pointer-address (null-pointer))
0)
(deftest pointer.null
(nth-value 0 (ignore-errors (null-pointer-p nil)))
nil)
(deftest foreign-pointer-type.nil
(typep nil 'foreign-pointer)
nil)
;;; Ensure that a pointer to the highest possible address can be
;;; created using MAKE-POINTER. Regression test for CLISP/X86-64.
(deftest make-pointer.high
(let* ((pointer-length (foreign-type-size :pointer))
(high-address (1- (expt 2 (* pointer-length 8))))
(pointer (make-pointer high-address)))
(- high-address (pointer-address pointer)))
0)
;;; Ensure that incrementing a pointer by zero bytes returns an
;;; equivalent pointer.
(deftest inc-pointer.zero
(with-foreign-object (x :int)
(pointer-eq x (inc-pointer x 0)))
t)
;;; Test the INITIAL-ELEMENT keyword argument to FOREIGN-ALLOC.
(deftest foreign-alloc.1
(let ((ptr (foreign-alloc :int :initial-element 42)))
(unwind-protect
(mem-ref ptr :int)
(foreign-free ptr)))
42)
;;; Test the INITIAL-ELEMENT and COUNT arguments to FOREIGN-ALLOC.
(deftest foreign-alloc.2
(let ((ptr (foreign-alloc :int :count 4 :initial-element 100)))
(unwind-protect
(loop for i from 0 below 4
collect (mem-aref ptr :int i))
(foreign-free ptr)))
(100 100 100 100))
;;; Test the INITIAL-CONTENTS and COUNT arguments to FOREIGN-ALLOC,
;;; passing a list of initial values.
(deftest foreign-alloc.3
(let ((ptr (foreign-alloc :int :count 4 :initial-contents '(4 3 2 1))))
(unwind-protect
(loop for i from 0 below 4
collect (mem-aref ptr :int i))
(foreign-free ptr)))
(4 3 2 1))
;;; Test INITIAL-CONTENTS and COUNT with FOREIGN-ALLOC passing a
;;; vector of initial values.
(deftest foreign-alloc.4
(let ((ptr (foreign-alloc :int :count 4 :initial-contents #(10 20 30 40))))
(unwind-protect
(loop for i from 0 below 4
collect (mem-aref ptr :int i))
(foreign-free ptr)))
(10 20 30 40))
;;; Ensure calling FOREIGN-ALLOC with both INITIAL-ELEMENT and
;;; INITIAL-CONTENTS signals an error.
(deftest foreign-alloc.5
(values
(ignore-errors
(let ((ptr (foreign-alloc :int :initial-element 1
:initial-contents '(1))))
(foreign-free ptr))
t))
nil)
;;; Regression test: FOREIGN-ALLOC shouldn't actually perform translation
;;; on initial-element/initial-contents since MEM-AREF will do that already.
(define-foreign-type not-an-int ()
()
(:actual-type :int)
(:simple-parser not-an-int))
(defmethod translate-to-foreign (value (type not-an-int))
(assert (not (integerp value)))
0)
(deftest foreign-alloc.6
(let ((ptr (foreign-alloc 'not-an-int :initial-element 'foooo)))
(foreign-free ptr)
t)
t)
;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P and a non-pointer
;;; type signals an error.
(deftest foreign-alloc.7
(values
(ignore-errors
(let ((ptr (foreign-alloc :int :null-terminated-p t)))
(foreign-free ptr))
t))
nil)
;;; The opposite of the above test.
(defctype pointer-alias :pointer)
(deftest foreign-alloc.8
(progn
(foreign-free (foreign-alloc 'pointer-alias :count 0 :null-terminated-p t))
t)
t)
;;; Ensure calling FOREIGN-ALLOC with NULL-TERMINATED-P actually places
;;; a null pointer at the end. Not a very reliable test apparently.
(deftest foreign-alloc.9
(let ((ptr (foreign-alloc :pointer :count 0 :null-terminated-p t)))
(unwind-protect
(null-pointer-p (mem-ref ptr :pointer))
(foreign-free ptr)))
t)
;;; RT: FOREIGN-ALLOC with :COUNT 0 on CLISP signalled an error.
(deftest foreign-alloc.10
(null (foreign-free (foreign-alloc :char :count 0)))
t)
;;; Tests for mem-ref with a non-constant type. This is a way to test
;;; the functional interface (without compiler macros).
(deftest deref.nonconst.char
(let ((type :char))
(with-foreign-object (p type)
(setf (mem-ref p type) -127)
(mem-ref p type)))
-127)
(deftest deref.nonconst.unsigned-char
(let ((type :unsigned-char))
(with-foreign-object (p type)
(setf (mem-ref p type) 255)
(mem-ref p type)))
255)
(deftest deref.nonconst.short
(let ((type :short))
(with-foreign-object (p type)
(setf (mem-ref p type) -32767)
(mem-ref p type)))
-32767)
(deftest deref.nonconst.unsigned-short
(let ((type :unsigned-short))
(with-foreign-object (p type)
(setf (mem-ref p type) 65535)
(mem-ref p type)))
65535)
(deftest deref.nonconst.int
(let ((type :int))
(with-foreign-object (p type)
(setf (mem-ref p type) -131072)
(mem-ref p type)))
-131072)
(deftest deref.nonconst.unsigned-int
(let ((type :unsigned-int))
(with-foreign-object (p type)
(setf (mem-ref p type) 262144)
(mem-ref p type)))
262144)
(deftest deref.nonconst.long
(let ((type :long))
(with-foreign-object (p type)
(setf (mem-ref p type) -536870911)
(mem-ref p type)))
-536870911)
(deftest deref.nonconst.unsigned-long
(let ((type :unsigned-long))
(with-foreign-object (p type)
(setf (mem-ref p type) 536870912)
(mem-ref p type)))
536870912)
#+(and darwin openmcl)
(pushnew 'deref.nonconst.long-long rt::*expected-failures*)
(deftest deref.nonconst.long-long
(let ((type :long-long))
(with-foreign-object (p type)
(setf (mem-ref p type) -9223372036854775807)
(mem-ref p type)))
-9223372036854775807)
(deftest deref.nonconst.unsigned-long-long
(let ((type :unsigned-long-long))
(with-foreign-object (p type)
(setf (mem-ref p type) 18446744073709551615)
(mem-ref p type)))
18446744073709551615)
(deftest deref.nonconst.float.1
(let ((type :float))
(with-foreign-object (p type)
(setf (mem-ref p type) 0.0)
(mem-ref p type)))
0.0)
(deftest deref.nonconst.float.2
(let ((type :float))
(with-foreign-object (p type)
(setf (mem-ref p type) *float-max*)
(mem-ref p type)))
#.*float-max*)
(deftest deref.nonconst.float.3
(let ((type :float))
(with-foreign-object (p type)
(setf (mem-ref p type) *float-min*)
(mem-ref p type)))
#.*float-min*)
(deftest deref.nonconst.double.1
(let ((type :double))
(with-foreign-object (p type)
(setf (mem-ref p type) 0.0d0)
(mem-ref p type)))
0.0d0)
(deftest deref.nonconst.double.2
(let ((type :double))
(with-foreign-object (p type)
(setf (mem-ref p type) *double-max*)
(mem-ref p type)))
#.*double-max*)
(deftest deref.nonconst.double.3
(let ((type :double))
(with-foreign-object (p type)
(setf (mem-ref p type) *double-min*)
(mem-ref p type)))
#.*double-min*)
;;; regression tests: lispworks's %mem-ref and %mem-set compiler
;;; macros were misbehaving.
(defun mem-ref-rt-1 ()
(with-foreign-object (a :int 2)
(setf (mem-aref a :int 0) 123
(mem-aref a :int 1) 456)
(values (mem-aref a :int 0) (mem-aref a :int 1))))
(deftest mem-ref.rt.1
(mem-ref-rt-1)
123 456)
(defun mem-ref-rt-2 ()
(with-foreign-object (a :double 2)
(setf (mem-aref a :double 0) 123.0d0
(mem-aref a :double 1) 456.0d0)
(values (mem-aref a :double 0) (mem-aref a :double 1))))
(deftest mem-ref.rt.2
(mem-ref-rt-2)
123.0d0 456.0d0)
(deftest incf-pointer.1
(let ((ptr (null-pointer)))
(incf-pointer ptr)
(pointer-address ptr))
1)
(deftest incf-pointer.2
(let ((ptr (null-pointer)))
(incf-pointer ptr 42)
(pointer-address ptr))
42)
(deftest pointerp.1
(values
(pointerp (null-pointer))
(null-pointer-p (null-pointer))
(typep (null-pointer) 'foreign-pointer))
t t t)
(deftest pointerp.2
(let ((p (make-pointer #xFEFF)))
(values
(pointerp p)
(typep p 'foreign-pointer)))
t t)
(deftest pointerp.3
(pointerp 'not-a-pointer)
nil)
(deftest pointerp.4
(pointerp 42)
nil)
(deftest pointerp.5
(pointerp 0)
nil)
(deftest pointerp.6
(pointerp nil)
nil)
(deftest mem-ref.setf.1
(with-foreign-object (p :char)
(setf (mem-ref p :char) 42))
42)
(define-foreign-type int+1 ()
()
(:actual-type :int)
(:simple-parser int+1))
(defmethod translate-to-foreign (value (type int+1))
(1+ value))
(defmethod translate-from-foreign (value (type int+1))
(1+ value))
(deftest mem-ref.setf.2
(with-foreign-object (p 'int+1)
(values (setf (mem-ref p 'int+1) 42)
(mem-ref p 'int+1)))
42 ; should this be 43?
44)
(deftest pointer-eq.non-pointers.1
(expecting-error (pointer-eq 1 2))
:error)
(deftest pointer-eq.non-pointers.2
(expecting-error (pointer-eq 'a 'b))
:error)
(deftest null-pointer-p.non-pointer.1
(expecting-error (null-pointer-p 'not-a-pointer))
:error)
(deftest null-pointer-p.non-pointer.2
(expecting-error (null-pointer-p 0))
:error)
(deftest null-pointer-p.non-pointer.3
(expecting-error (null-pointer-p nil))
:error)

296
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/misc-types.lisp Normal file
View file

@ -0,0 +1,296 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; misc-types.lisp --- Various tests on the type system.
;;;
;;; Copyright (C) 2005-2006, 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)
(defcfun ("my_strdup" strdup) :string+ptr (str :string))
(defcfun ("my_strfree" strfree) :void (str :pointer))
(deftest misc-types.string+ptr
(destructuring-bind (string pointer)
(strdup "foo")
(strfree pointer)
string)
"foo")
#-(and)
(deftest misc-types.string+ptr.ub8
(destructuring-bind (string pointer)
(strdup (make-array 3 :element-type '(unsigned-byte 8)
:initial-contents (map 'list #'char-code "foo")))
(strfree pointer)
string)
"foo")
#-(and)
(deftest misc-types.string.ub8.1
(let ((array (make-array 7 :element-type '(unsigned-byte 8)
:initial-contents '(84 117 114 97 110 103 97))))
(with-foreign-string (foreign-string array)
(foreign-string-to-lisp foreign-string)))
"Turanga")
#-(and)
(deftest misc-types.string.ub8.2
(let ((str (foreign-string-alloc
(make-array 7 :element-type '(unsigned-byte 8)
:initial-contents '(84 117 114 97 110 103 97)))))
(prog1 (foreign-string-to-lisp str)
(foreign-string-free str)))
"Turanga")
(defcfun "equalequal" :boolean
(a (:boolean :int))
(b (:boolean :unsigned-int)))
(defcfun "bool_and" (:boolean :char)
(a (:boolean :unsigned-char))
(b (:boolean :char)))
(defcfun "bool_xor" (:boolean :unsigned-long)
(a (:boolean :long))
(b (:boolean :unsigned-long)))
(deftest misc-types.boolean.1
(list (equalequal nil nil)
(equalequal t t)
(equalequal t 23)
(bool-and 'a 'b)
(bool-and "foo" nil)
(bool-xor t nil)
(bool-xor nil nil))
(t t t t nil t nil))
(defcfun "sizeof_bool" :unsigned-int)
(deftest misc-types.sizeof.bool
(eql (sizeof-bool) (foreign-type-size :bool))
t)
(defcfun "bool_to_unsigned" :unsigned-int
(b :bool))
(defcfun "unsigned_to_bool" :bool
(u :unsigned-int))
(deftest misc-types.bool.convert-to-foreign.mem
(loop for v in '(nil t)
collect
(with-foreign-object (b :bool)
(setf (mem-ref b :bool) v)
(mem-ref b #.(cffi::canonicalize-foreign-type :bool))))
(0 1))
(deftest misc-types.bool.convert-to-foreign.call
(mapcar #'bool-to-unsigned '(nil t))
(0 1))
(deftest misc-types.bool.convert-from-foreign.mem
(loop for v in '(0 1 42)
collect
(with-foreign-object (b :bool)
(setf (mem-ref b #.(cffi::canonicalize-foreign-type :bool)) v)
(mem-ref b :bool)))
(nil t t))
(deftest misc-types.bool.convert-from-foreign.call
(mapcar #'unsigned-to-bool '(0 1 42))
(nil t t))
;;; Regression test: boolean type only worked with canonicalized
;;; built-in integer types. Should work for any type that canonicalizes
;;; to a built-in integer type.
(defctype int-for-bool :int)
(defcfun ("equalequal" equalequal2) :boolean
(a (:boolean int-for-bool))
(b (:boolean :uint)))
(deftest misc-types.boolean.2
(equalequal2 nil t)
nil)
(defctype my-string :string+ptr)
(defun funkify (str)
(concatenate 'string "MORE " (string-upcase str)))
(defun 3rd-person (value)
(list (concatenate 'string "Strdup says: " (first value))
(second value)))
;; (defctype funky-string
;; (:wrapper my-string
;; :to-c #'funkify
;; :from-c (lambda (value)
;; (list
;; (concatenate 'string "Strdup says: "
;; (first value))
;; (second value))))
;; "A useful type.")
(defctype funky-string (:wrapper my-string :to-c funkify :from-c 3rd-person))
(defcfun ("my_strdup" funky-strdup) funky-string
(str funky-string))
(deftest misc-types.wrapper
(destructuring-bind (string ptr)
(funky-strdup "code")
(strfree ptr)
string)
"Strdup says: MORE CODE")
(deftest misc-types.sized-ints
(mapcar #'foreign-type-size
'(:int8 :uint8 :int16 :uint16 :int32 :uint32 :int64 :uint64))
(1 1 2 2 4 4 8 8))
(define-foreign-type error-error ()
()
(:actual-type :int)
(:simple-parser error-error))
(defmethod translate-to-foreign (value (type error-error))
(declare (ignore value))
(error "translate-to-foreign invoked."))
(defmethod translate-from-foreign (value (type error-error))
(declare (ignore value))
(error "translate-from-foreign invoked."))
(eval-when (:load-toplevel :compile-toplevel :execute)
(defmethod expand-to-foreign (value (type error-error))
value)
(defmethod expand-from-foreign (value (type error-error))
value))
(defcfun ("abs" expand-abs) error-error
(n error-error))
(defcvar ("var_int" *expand-var-int*) error-error)
(defcfun ("expect_int_sum" expand-expect-int-sum) :boolean
(cb :pointer))
(defcallback expand-int-sum error-error ((x error-error) (y error-error))
(+ x y))
;;; Ensure that macroexpansion-time translators are called where this
;;; is guaranteed (defcfun, defcvar, foreign-funcall and defcallback)
(deftest misc-types.expand.1
(expand-abs -1)
1)
#-cffi-sys::no-foreign-funcall
(deftest misc-types.expand.2
(foreign-funcall "abs" error-error -1 error-error)
1)
(deftest misc-types.expand.3
(let ((old (mem-ref (get-var-pointer '*expand-var-int*) :int)))
(unwind-protect
(progn
(setf *expand-var-int* 42)
*expand-var-int*)
(setf (mem-ref (get-var-pointer '*expand-var-int*) :int) old)))
42)
(deftest misc-types.expand.4
(expand-expect-int-sum (callback expand-int-sum))
t)
(define-foreign-type translate-tracker ()
()
(:actual-type :int)
(:simple-parser translate-tracker))
(declaim (special .fto-called.))
(defmethod free-translated-object (value (type translate-tracker) param)
(declare (ignore value param))
(setf .fto-called. t))
(define-foreign-type expand-tracker ()
()
(:actual-type :int)
(:simple-parser expand-tracker))
(defmethod free-translated-object (value (type expand-tracker) param)
(declare (ignore value param))
(setf .fto-called. t))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod expand-to-foreign (value (type expand-tracker))
(declare (ignore value))
(call-next-method)))
(defcfun ("abs" ttracker-abs) :int
(n translate-tracker))
(defcfun ("abs" etracker-abs) :int
(n expand-tracker))
;; free-translated-object must be called when there is no etf
(deftest misc-types.expand.5
(let ((.fto-called. nil))
(ttracker-abs -1)
.fto-called.)
t)
;; free-translated-object must be called when there is an etf, but
;; they answer *runtime-translator-form*
(deftest misc-types.expand.6
(let ((.fto-called. nil))
(etracker-abs -1)
.fto-called.)
t)
(define-foreign-type misc-type.expand.7 ()
()
(:actual-type :int)
(:simple-parser misc-type.expand.7))
(defmethod translate-to-foreign (value (type misc-type.expand.7))
(values value 'second-value))
;; Auxiliary function to test CONVERT-TO-FOREIGN's compiler macro.
(defun misc-type.expand.7-aux ()
(convert-to-foreign "foo" 'misc-type.expand.7))
;; Checking that expand-to-foreign doesn't ignore the second value of
;; translate-to-foreign.
(deftest misc-type.expand.7
(misc-type.expand.7-aux)
"foo" second-value)
;; Like MISC-TYPE.EXPAND.7 but doesn't depend on compiler macros
;; kicking in.
(deftest misc-type.expand.8
(eval (expand-to-foreign "foo" (cffi::parse-type 'misc-type.expand.7)))
"foo" second-value)

132
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/misc.lisp Normal file
View file

@ -0,0 +1,132 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; misc.lisp --- Miscellaneous tests.
;;;
;;; Copyright (C) 2006, 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)
;;;# foreign-symbol-pointer tests
;;; This might be useful for some libraries that compare function
;;; pointers. http://thread.gmane.org/gmane.lisp.cffi.devel/694
(defcfun "compare_against_abs" :boolean (p :pointer))
(deftest foreign-symbol-pointer.1
(compare-against-abs (foreign-symbol-pointer "abs"))
t)
(defcfun "compare_against_xpto_fun" :boolean (p :pointer))
(deftest foreign-symbol-pointer.2
(compare-against-xpto-fun (foreign-symbol-pointer "xpto_fun"))
t)
;;;# Library tests
;;;
;;; Need to figure out a way to test this. CLISP, for instance, will
;;; automatically reopen the foreign-library when we call a foreign
;;; function so we can't test CLOSE-FOREIGN-LIBRARY this way.
;;;
;;; IIRC, GCC has some extensions to have code run when a library is
;;; loaded and stuff like that. That could work.
#||
#-(and ecl (not dffi))
(deftest library.close.2
(unwind-protect
(progn
(close-foreign-library 'libtest)
(ignore-errors (my-sqrtf 16.0)))
(load-test-libraries))
nil)
#-(or (and ecl (not dffi))
cffi-sys::flat-namespace
cffi-sys::no-foreign-funcall)
(deftest library.close.2
(unwind-protect
(values
(foreign-funcall ("ns_function" :library libtest) :boolean)
(close-foreign-library 'libtest)
(foreign-funcall "ns_function" :boolean)
(close-foreign-library 'libtest2)
(close-foreign-library 'libtest2)
(ignore-errors (foreign-funcall "ns_function" :boolean)))
(load-test-libraries))
t t nil t nil nil)
||#
(deftest library.error.1
(handler-case (load-foreign-library "libdoesnotexistimsure")
(load-foreign-library-error () 'error))
error)
(define-foreign-library pseudo-library
(t pseudo-library-spec))
;;; RT: T clause was being handled as :T by FEATUREP.
;;;
;;; We might want to export (and clean up) the API used in this test
;;; when the need arises.
(deftest library.t-clause
(eq (cffi::foreign-library-spec
(cffi::get-foreign-library 'pseudo-library))
'pseudo-library-spec)
t)
(define-foreign-library library-with-pathname
(t #p"libdoesnotexistimsure"))
;;; RT: we were mishandling pathnames within libraries. (lp#1720626)
(deftest library.error.2
(handler-case (load-foreign-library 'library-with-pathname)
(load-foreign-library-error () 'error))
error)
(deftest library.error.3
(handler-case (load-foreign-library #p"libdoesnotexistimsure")
(load-foreign-library-error () 'error))
error)
;;;# Shareable Byte Vector Tests
#+ecl
(mapc (lambda (x) (pushnew x rt::*expected-failures*))
'(shareable-vector.1 shareable-vector.2))
(deftest shareable-vector.1
(let ((vector (cffi-sys::make-shareable-byte-vector 5)))
(cffi::with-pointer-to-vector-data (pointer vector)
(strcpy pointer "xpto"))
vector)
#(120 112 116 111 0))
(deftest shareable-vector.2
(block nil
(let ((vector (cffi-sys::make-shareable-byte-vector 5)))
(cffi::with-pointer-to-vector-data (pointer vector)
(strcpy pointer "xpto")
(return vector))))
#(120 112 116 111 0))

33
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/package.lisp Normal file
View file

@ -0,0 +1,33 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; package.lisp --- CFFI-TESTS package definition.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; 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 #:cl-user)
(defpackage #:cffi-tests
(:use #:cl #:cffi #:cffi-sys #:regression-test)
(:export #:do-tests #:run-cffi-tests #:run-all-cffi-tests)
(:shadow #:deftest))

246
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/random-tester.lisp Normal file
View file

@ -0,0 +1,246 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; random-tester.lisp --- Random test generator.
;;;
;;; Copyright (C) 2006, 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.
;;;
;;; This code was used to generate the C and Lisp source code for
;;; the CALLBACKS.BFF.[12] and DEFCFUN.BFF.[12] tests.
;;;
;;; The original idea was to test all combinations of argument types
;;; but obviously as soon as you do the maths that it's not quite
;;; feasable for more that 4 or 5 arguments.
;;;
;;; TODO: actually run random tests, ie compile/load/run the tests
;;; this code can generate.
(defpackage #:cffi-random-tester
(:use #:cl #:cffi #:alexandria #:regression-test))
(in-package #:cffi-random-tester)
(defstruct (c-type (:conc-name type-))
keyword
name
abbrev
min
max)
(defparameter +types+
(mapcar (lambda (type)
(let ((keyword (first type))
(name (second type)))
(multiple-value-bind (min max)
;; assume we can represent an integer in the range
;; [-2^16 2^16-1] in a float/double without causing
;; rounding errors (probably a lame assumption)
(let ((type-size (if (or (eq keyword :float)
(eq keyword :double))
16
(* 8 (foreign-type-size keyword)))))
(if (or (eql (char name 0) #\u) (eq keyword :pointer))
(values 0 (1- (expt 2 type-size)))
(values (- (expt 2 (1- type-size)))
(1- (expt 2 (1- type-size))))))
(make-c-type :keyword keyword :name name :abbrev (third type)
:min min :max max))))
'((:char "char" "c")
(:unsigned-char "unsigned char" "uc")
(:short "short" "s")
(:unsigned-short "unsigned short" "us")
(:int "int" "i")
(:unsigned-int "unsigned int" "ui")
(:long "long" "l")
(:unsigned-long "unsigned long" "ul")
(:float "float" "f")
(:double "double" "d")
(:pointer "void*" "p")
(:long-long "long long" "ll")
(:unsigned-long-long "unsigned long long" "ull"))))
(defun find-type (keyword)
(find keyword +types+ :key #'type-keyword))
(defun n-random-types (n)
(loop repeat n collect (nth (random (length +types+)) +types+)))
;;; same as above, without the long long types
(defun n-random-types-no-ll (n)
(loop repeat n collect (nth (random (- (length +types+) 2)) +types+)))
(defun random-range (x y)
(+ x (random (+ (- y x) 2))))
(defun random-sum (rettype arg-types)
"Returns a list of integers that fit in the respective types in the
ARG-TYPES list and whose sum fits in RETTYPE."
(loop with sum = 0
for type in arg-types
for x = (random-range (max (- (type-min rettype) sum) (type-min type))
(min (- (type-max rettype) sum) (type-max type)))
do (incf sum x)
collect x))
(defun combinations (n items)
(let ((combs '()))
(labels ((rec (n accum)
(if (= n 0)
(push accum combs)
(loop for item in items
do (rec (1- n) (cons item accum))))))
(rec n '())
combs)))
(defun function-name (rettype arg-types)
(format nil "sum_~A_~{_~A~}"
(type-abbrev rettype)
(mapcar #'type-abbrev arg-types)))
(defun c-function (rettype arg-types)
(let ((args (loop for type in arg-types and i from 1
collect (list (type-name type) (format nil "a~A" i)))))
(format t "DLLEXPORT ~A ~A(~{~{~A ~A~}~^, ~})~%~
{ return ~A(~A) ~{~A~^ + ~}~A; }"
(type-name rettype) (function-name rettype arg-types) args
(if (eq (type-keyword rettype) :pointer)
"(void *)((unsigned int)("
"")
(type-name rettype)
(loop for arg-pair in args collect
(format nil "~A~A~A"
(cond ((string= (first arg-pair) "void*")
"(unsigned int) ")
((or (string= (first arg-pair) "double")
(string= (first arg-pair) "float"))
"((int) ")
(t ""))
(second arg-pair)
(if (member (first arg-pair)
'("void*" "double" "float")
:test #'string=)
")"
"")))
(if (eq (type-keyword rettype) :pointer) "))" ""))))
(defun c-callback (rettype arg-types args)
(format t "DLLEXPORT ~A call_~A(~A (*func)(~{~A~^, ~}~^))~%~
{ return func(~{~A~^, ~}); }"
(type-name rettype) (function-name rettype arg-types)
(type-name rettype) (mapcar #'type-name arg-types)
(loop for type in arg-types and value in args collect
(format nil "~A~A"
(if (eq (type-keyword type) :pointer)
"(void *) "
"")
value))))
;;; (output-c-code #p"generated.c" 3 5)
(defun output-c-code (file min max)
(with-open-file (stream file :direction :output :if-exists :error)
(let ((*standard-output* stream))
(format t "/* automatically generated functions and callbacks */~%~%")
(loop for n from min upto max do
(format t "/* ~A args */" (1- n))
(loop for comb in (combinations n +types+) do
(terpri) (c-function (car comb) (cdr comb))
(terpri) (c-callback (car comb) (cdr comb)))))))
(defmacro with-conversion (type form)
(case type
(:double `(float ,form 1.0d0))
(:float `(float ,form))
(:pointer `(make-pointer ,form))
(t form)))
(defun integer-conversion (type form)
(case type
((:double :float) `(values (floor ,form)))
(:pointer `(pointer-address ,form))
(t form)))
(defun gen-arg-values (rettype arg-types)
(let ((numbers (random-sum rettype arg-types)))
(values
(reduce #'+ numbers)
(loop for type in arg-types and n in numbers
collect (case (type-keyword type)
(:double (float n 1.0d0))
(:float (float n))
(:pointer `(make-pointer ,n))
(t n))))))
(defun gen-function-test (rettype arg-types)
(let* ((fun-name (function-name rettype arg-types))
(fun-sym (cffi::lisp-function-name fun-name)))
(multiple-value-bind (sum value-forms)
(gen-arg-values rettype arg-types)
`(progn
(defcfun (,fun-name ,fun-sym) ,(type-keyword rettype)
,@(loop for type in arg-types and i from 1 collect
(list (symbolicate '#:a (format nil "~A" i))
(type-keyword type))))
(deftest ,(symbolicate '#:defcfun. fun-sym)
,(integer-conversion (type-keyword rettype)
`(,fun-sym ,@value-forms))
,sum)))))
(defun gen-callback-test (rettype arg-types sum)
(let* ((fname (function-name rettype arg-types))
(cb-sym (cffi::lisp-function-name fname))
(fun-name (concatenate 'string "call_" fname))
(fun-sym (cffi::lisp-function-name fun-name))
(arg-names (loop for i from 1 upto (length arg-types) collect
(symbolicate '#:a (format nil "~A" i)))))
`(progn
(defcfun (,fun-name ,fun-sym) ,(type-keyword rettype) (cb :pointer))
(defcallback ,cb-sym ,(type-keyword rettype)
,(loop for type in arg-types and name in arg-names
collect (list name (type-keyword type)))
,(integer-conversion
(type-keyword rettype)
`(+ ,@(mapcar (lambda (tp n)
(integer-conversion (type-keyword tp) n))
arg-types arg-names))))
(deftest ,(symbolicate '#:callbacks. cb-sym)
,(integer-conversion (type-keyword rettype)
`(,fun-sym (callback ,cb-sym)))
,sum))))
(defun cb-test (&key no-long-long)
(let* ((rettype (find-type (if no-long-long :long :long-long)))
(arg-types (if no-long-long
(n-random-types-no-ll 127)
(n-random-types 127)))
(args (random-sum rettype arg-types))
(sum (reduce #'+ args)))
(c-callback rettype arg-types args)
(gen-callback-test rettype arg-types sum)))
;; (defmacro define-function-and-callback-tests (min max)
;; `(progn
;; ,@(loop for n from min upto max appending
;; (loop for comb in (combinations n +types+)
;; collect (gen-function-test (car comb) (cdr comb))
;; collect (gen-callback-test (car comb) (cdr comb))))))
;; (define-function-and-callback-tests 3 5)

44
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/run-tests.lisp Normal file
View file

@ -0,0 +1,44 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; run-tests.lisp --- Simple script to run the unit tests.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; 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 #:cl-user)
(setf *load-verbose* nil *compile-verbose* nil *compile-print* nil)
#+cmucl (setf ext:*gc-verbose* nil)
(require "asdf")
(format t "~&;;; -------- Running tests in ~A --------~%"
(uiop:implementation-identifier))
(asdf:load-system "cffi-tests" :verbose nil)
(asdf:test-system "cffi-tests")
(terpri)
(force-output)
(uiop:quit)

150
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/strings.lisp Normal file
View file

@ -0,0 +1,150 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; strings.lisp --- Tests for foreign string conversion.
;;;
;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 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)
;;;# Foreign String Conversion Tests
;;;
;;; With the implementation of encoding support, there are a lot of
;;; things that can go wrong with foreign string conversions. This is
;;; a start at defining tests for strings and encoding conversion, but
;;; there needs to be a lot more.
(babel:enable-sharp-backslash-syntax)
;;; *ASCII-TEST-STRING* contains the characters in the ASCII character
;;; set that we will convert to a foreign string and check against
;;; *ASCII-TEST-BYTES*. We don't bother with control characters.
;;;
;;; FIXME: It would probably be good to move these tables into files
;;; in "tests/", especially if we ever want to get fancier and have
;;; tests for more encodings.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *ascii-test-string*
(concatenate 'string " !\"#$%&'()*+,-./0123456789:;"
"<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]"
"^_`abcdefghijklmnopqrstuvwxyz{|}~")))
;;; *ASCII-TEST-BYTES* contains the expected ASCII encoded values
;;; for each character in *ASCII-TEST-STRING*.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *ascii-test-bytes*
(let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
(loop for i from 0
for code from 32 below 127
do (setf (aref vector i) code)
finally (return vector)))))
;;; Test basic consistency converting a string to and from Lisp using
;;; the default encoding.
(deftest string.conversion.basic
(with-foreign-string (s *ascii-test-string*)
(foreign-string-to-lisp s))
#.*ascii-test-string* 95)
(deftest string.conversion.basic.2
(with-foreign-string ((ptr size) "123" :null-terminated-p nil)
(values (foreign-string-to-lisp ptr :count 3) size))
"123" 3)
;;; Ensure that conversion of *ASCII-TEST-STRING* to a foreign buffer
;;; and back preserves ASCII encoding.
(deftest string.encoding.ascii
(with-foreign-string (s *ascii-test-string* :encoding :ascii)
(let ((vector (make-array 95 :element-type '(unsigned-byte 8))))
(loop for i from 0 below (length vector)
do (setf (aref vector i) (mem-ref s :unsigned-char i)))
vector))
#.*ascii-test-bytes*)
;;; FIXME: bogus test. We need support for BOM or UTF-16{BE,LE}.
(pushnew 'string.encoding.utf-16.basic rtest::*expected-failures*)
;;; Test UTF-16 conversion of a string back and forth. Tests proper
;;; null terminator handling for wide character strings and ensures no
;;; byte order marks are added. (Why no BOM? --luis)
;;;
;;; FIXME: an identical test using :UTF-16 wouldn't work because on
;;; little-endian architectures, :UTF-16 defaults to little-endian
;;; when writing and big-endian on reading because the BOM is
;;; suppressed.
#-babel::8-bit-chars
(progn
(deftest string.encoding.utf-16le.basic
(with-foreign-string (s *ascii-test-string* :encoding :utf-16le)
(foreign-string-to-lisp s :encoding :utf-16le))
#.*ascii-test-string* 190)
(deftest string.encoding.utf-16be.basic
(with-foreign-string (s *ascii-test-string* :encoding :utf-16be)
(foreign-string-to-lisp s :encoding :utf-16be))
#.*ascii-test-string* 190))
;;; Ensure that writing a long string into a short buffer does not
;;; attempt to write beyond the edge of the buffer, and that the
;;; resulting string is still null terminated.
(deftest string.short-write.1
(with-foreign-pointer (buf 6)
(setf (mem-ref buf :unsigned-char 5) 70)
(lisp-string-to-foreign "ABCDE" buf 5 :encoding :ascii)
(values (mem-ref buf :unsigned-char 4)
(mem-ref buf :unsigned-char 5)))
0 70)
#-babel::8-bit-chars
(deftest string.encoding.utf-8.basic
(with-foreign-pointer (buf 7 size)
(let ((string (concatenate 'babel:unicode-string
'(#\u03bb #\u00e3 #\u03bb))))
(lisp-string-to-foreign string buf size :encoding :utf-8)
(loop for i from 0 below size
collect (mem-ref buf :unsigned-char i))))
(206 187 195 163 206 187 0))
(defparameter *basic-latin-alphabet* "abcdefghijklmnopqrstuvwxyz")
(deftest string.encodings.all.basic
(let (failed)
;;; FIXME: UTF-{32,16} and friends fail due to lack of BOM. See
;;; STRING.ENCODING.UTF-16.BASIC for more details.
(dolist (encoding (remove-if (lambda (x)
(member x '(:utf-32 :utf-16 :ucs-2)))
(babel:list-character-encodings)))
;; (format t "Testing ~S~%" encoding)
(with-foreign-string (ptr *basic-latin-alphabet* :encoding encoding)
(let ((string (foreign-string-to-lisp ptr :encoding encoding)))
;; (format t " got ~S~%" string)
(unless (string= *basic-latin-alphabet* string)
(push encoding failed)))))
failed)
nil)
;;; rt: make sure *default-foreign-enconding* binds to a keyword
(deftest string.encodings.default
(keywordp *default-foreign-encoding*)
t)

705
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/struct.lisp Normal file
View file

@ -0,0 +1,705 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; struct.lisp --- Foreign structure type tests.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;; Copyright (C) 2005-2011, 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)
(defcstruct timeval
(tv-secs :long)
(tv-usecs :long))
(defparameter *timeval-size* (* 2 (max (foreign-type-size :long)
(foreign-type-alignment :long))))
;;;# Basic Structure Tests
(deftest struct.1
(- (foreign-type-size 'timeval) *timeval-size*)
0)
(deftest struct.2
(with-foreign-object (tv 'timeval)
(setf (foreign-slot-value tv 'timeval 'tv-secs) 0)
(setf (foreign-slot-value tv 'timeval 'tv-usecs) 1)
(values (foreign-slot-value tv 'timeval 'tv-secs)
(foreign-slot-value tv 'timeval 'tv-usecs)))
0 1)
(deftest struct.3
(with-foreign-object (tv 'timeval)
(with-foreign-slots ((tv-secs tv-usecs) tv timeval)
(setf tv-secs 100 tv-usecs 200)
(values tv-secs tv-usecs)))
100 200)
;; regression test: accessing a struct through a typedef
(defctype xpto (:struct timeval))
(deftest struct.4
(with-foreign-object (tv 'xpto)
(setf (foreign-slot-value tv 'xpto 'tv-usecs) 1)
(values (foreign-slot-value tv 'xpto 'tv-usecs)
(foreign-slot-value tv 'timeval 'tv-usecs)))
1 1)
(deftest struct.names
(sort (foreign-slot-names 'xpto) #'<
:key (lambda (x) (foreign-slot-offset 'xpto x)))
(tv-secs tv-usecs))
;; regression test: compiler macro not quoting the type in the
;; resulting mem-ref form. The compiler macro on foreign-slot-value
;; is not guaranteed to be expanded though.
(defctype my-int :int)
(defcstruct s5 (a my-int))
(deftest struct.5
(with-foreign-object (s 's5)
(setf (foreign-slot-value s 's5 'a) 42)
(foreign-slot-value s 's5 'a))
42)
;;;# Structs with type translators
(defcstruct struct-string
(s :string))
(deftest struct.string.1
(with-foreign-object (ptr 'struct-string)
(with-foreign-slots ((s) ptr struct-string)
(setf s "So long and thanks for all the fish!")
s))
"So long and thanks for all the fish!")
(deftest struct.string.2
(with-foreign-object (ptr 'struct-string)
(setf (foreign-slot-value ptr 'struct-string 's) "Cha")
(foreign-slot-value ptr 'struct-string 's))
"Cha")
;;;# Structure Alignment Tests
;;;
;;; See libtest.c and types.lisp for some comments about alignments.
(defcstruct s-ch
(a-char :char))
(defctype s-ch (:struct s-ch))
(defcstruct s-s-ch
(another-char :char)
(a-s-ch s-ch))
(defctype s-s-ch (:struct s-s-ch))
(defcvar "the_s_s_ch" s-s-ch)
(deftest struct.alignment.1
(list 'a-char (foreign-slot-value
(foreign-slot-pointer *the-s-s-ch* 's-s-ch 'a-s-ch)
's-ch 'a-char)
'another-char (foreign-slot-value *the-s-s-ch* 's-s-ch 'another-char))
(a-char 1 another-char 2))
(defcstruct s-short
(a-char :char)
(another-char :char)
(a-short :short))
(defctype s-short (:struct s-short))
(defcstruct s-s-short
(yet-another-char :char)
(a-s-short s-short))
(defctype s-s-short (:struct s-s-short))
(defcvar "the_s_s_short" s-s-short)
(deftest struct.alignment.2
(with-foreign-slots ((yet-another-char a-s-short) *the-s-s-short* s-s-short)
(with-foreign-slots ((a-char another-char a-short) a-s-short s-short)
(list 'a-char a-char
'another-char another-char
'a-short a-short
'yet-another-char yet-another-char)))
(a-char 1 another-char 2 a-short 3 yet-another-char 4))
(defcstruct s-double
(a-char :char)
(a-double :double)
(another-char :char))
(defctype s-double (:struct s-double))
(defcstruct s-s-double
(yet-another-char :char)
(a-s-double s-double)
(a-short :short))
(defctype s-s-double (:struct s-s-double))
(defcvar "the_s_s_double" s-s-double)
(deftest struct.alignment.3
(with-foreign-slots
((yet-another-char a-s-double a-short) *the-s-s-double* s-s-double)
(with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
(list 'a-char a-char
'a-double a-double
'another-char another-char
'yet-another-char yet-another-char
'a-short a-short)))
(a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5))
(defcstruct s-s-s-double
(another-short :short)
(a-s-s-double s-s-double)
(last-char :char))
(defctype s-s-s-double (:struct s-s-s-double))
(defcvar "the_s_s_s_double" s-s-s-double)
(deftest struct.alignment.4
(with-foreign-slots
((another-short a-s-s-double last-char) *the-s-s-s-double* s-s-s-double)
(with-foreign-slots
((yet-another-char a-s-double a-short) a-s-s-double s-s-double)
(with-foreign-slots ((a-char a-double another-char) a-s-double s-double)
(list 'a-char a-char
'a-double a-double
'another-char another-char
'yet-another-char yet-another-char
'a-short a-short
'another-short another-short
'last-char last-char))))
(a-char 1 a-double 2.0d0 another-char 3 yet-another-char 4 a-short 5
another-short 6 last-char 7))
(defcstruct s-double2
(a-double :double)
(a-short :short))
(defctype s-double2 (:struct s-double2))
(defcstruct s-s-double2
(a-char :char)
(a-s-double2 s-double2)
(another-short :short))
(defctype s-s-double2 (:struct s-s-double2))
(defcvar "the_s_s_double2" s-s-double2)
(deftest struct.alignment.5
(with-foreign-slots
((a-char a-s-double2 another-short) *the-s-s-double2* s-s-double2)
(with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
(list 'a-double a-double
'a-short a-short
'a-char a-char
'another-short another-short)))
(a-double 1.0d0 a-short 2 a-char 3 another-short 4))
(defcstruct s-long-long
(a-long-long :long-long)
(a-short :short))
(defctype s-long-long (:struct s-long-long))
(defcstruct s-s-long-long
(a-char :char)
(a-s-long-long s-long-long)
(another-short :short))
(defctype s-s-long-long (:struct s-s-long-long))
(defcvar "the_s_s_long_long" s-s-long-long)
(deftest struct.alignment.6
(with-foreign-slots
((a-char a-s-long-long another-short) *the-s-s-long-long* s-s-long-long)
(with-foreign-slots ((a-long-long a-short) a-s-long-long s-long-long)
(list 'a-long-long a-long-long
'a-short a-short
'a-char a-char
'another-short another-short)))
(a-long-long 1 a-short 2 a-char 3 another-short 4))
(defcstruct s-s-double3
(a-s-double2 s-double2)
(another-short :short))
(defctype s-s-double3 (:struct s-s-double3))
(defcstruct s-s-s-double3
(a-s-s-double3 s-s-double3)
(a-char :char))
(defctype s-s-s-double3 (:struct s-s-s-double3))
(defcvar "the_s_s_s_double3" s-s-s-double3)
(deftest struct.alignment.7
(with-foreign-slots ((a-s-s-double3 a-char) *the-s-s-s-double3* s-s-s-double3)
(with-foreign-slots ((a-s-double2 another-short) a-s-s-double3 s-s-double3)
(with-foreign-slots ((a-double a-short) a-s-double2 s-double2)
(list 'a-double a-double
'a-short a-short
'another-short another-short
'a-char a-char))))
(a-double 1.0d0 a-short 2 another-short 3 a-char 4))
(defcstruct empty-struct)
(defctype empty-struct (:struct empty-struct))
(defcstruct with-empty-struct
(foo empty-struct)
(an-int :int))
;; commented out this test because an empty struct is not valid/standard C
;; left the struct declarations anyway because they should be handled
;; gracefuly anyway.
; (defcvar "the_with_empty_struct" with-empty-struct)
;
; (deftest struct.alignment.5
; (with-foreign-slots ((foo an-int) *the-with-empty-struct* with-empty-struct)
; an-int)
; 42)
;; regression test, setf-ing nested foreign-slot-value forms
;; the setf expander used to return a bogus getter
(defcstruct s1
(an-int :int))
(defctype s1 (:struct s1))
(defcstruct s2
(an-s1 s1))
(defctype s2 (:struct s2))
(deftest struct.nested-setf
(with-foreign-object (an-s2 's2)
(setf (foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
's1 'an-int)
1984)
(foreign-slot-value (foreign-slot-value an-s2 's2 'an-s1)
's1 'an-int))
1984)
;; regression test, some Lisps were returning 4 instead of 8 for
;; (foreign-type-alignment :unsigned-long-long) on darwin/ppc32
(defcstruct s-unsigned-long-long
(an-unsigned-long-long :unsigned-long-long)
(a-short :short))
(defctype s-unsigned-long-long (:struct s-unsigned-long-long))
(defcstruct s-s-unsigned-long-long
(a-char :char)
(a-s-unsigned-long-long s-unsigned-long-long)
(another-short :short))
(defctype s-s-unsigned-long-long (:struct s-s-unsigned-long-long))
(defcvar "the_s_s_unsigned_long_long" s-s-unsigned-long-long)
(deftest struct.alignment.8
(with-foreign-slots
((a-char a-s-unsigned-long-long another-short)
*the-s-s-unsigned-long-long* s-s-unsigned-long-long)
(with-foreign-slots ((an-unsigned-long-long a-short)
a-s-unsigned-long-long s-unsigned-long-long)
(list 'an-unsigned-long-long an-unsigned-long-long
'a-short a-short
'a-char a-char
'another-short another-short)))
(an-unsigned-long-long 1 a-short 2 a-char 3 another-short 4))
;;;# C Struct Wrappers
(define-c-struct-wrapper timeval ())
(define-c-struct-wrapper (timeval2 (:struct timeval)) ()
(tv-secs))
(defmacro with-example-timeval (var &body body)
`(with-foreign-object (,var 'timeval)
(with-foreign-slots ((tv-secs tv-usecs) ,var timeval)
(setf tv-secs 42 tv-usecs 1984)
,@body)))
(deftest struct-wrapper.1
(with-example-timeval ptr
(let ((obj (make-instance 'timeval :pointer ptr)))
(values (timeval-tv-secs obj)
(timeval-tv-usecs obj))))
42 1984)
(deftest struct-wrapper.2
(with-example-timeval ptr
(let ((obj (make-instance 'timeval2 :pointer ptr)))
(timeval2-tv-secs obj)))
42)
;;;# Structures as Values
(defcstruct (struct-pair :class pair)
(a :int)
(b :int))
(defctype struct-pair-typedef1 (:struct struct-pair))
(defctype struct-pair-typedef2 (:pointer (:struct struct-pair)))
(deftest struct.unparse.1
(mapcar (alexandria:compose #'cffi::unparse-type #'cffi::parse-type)
'(struct-pair
(:struct struct-pair)
struct-pair-typedef1
struct-pair-typedef2))
(struct-pair
(:struct struct-pair)
struct-pair-typedef1
struct-pair-typedef2))
(deftest struct.canonicalize.1
(mapcar #'cffi::canonicalize-foreign-type
'(struct-pair
(:struct struct-pair)
struct-pair-typedef1
struct-pair-typedef2))
(:pointer
(:struct struct-pair)
(:struct struct-pair)
:pointer))
(deftest struct.canonicalize.2
(mapcar #'cffi::canonicalize-foreign-type
'(struct-pair
(:struct struct-pair)
struct-pair-typedef1
struct-pair-typedef2))
(:pointer
(:struct struct-pair)
(:struct struct-pair)
:pointer))
(defmethod translate-from-foreign (pointer (type pair))
(with-foreign-slots ((a b) pointer (:struct struct-pair))
(cons a b)))
(defmethod translate-into-foreign-memory (object (type pair) pointer)
(with-foreign-slots ((a b) pointer (:struct struct-pair))
(setf a (car object)
b (cdr object))))
(defmethod translate-to-foreign (object (type pair))
(let ((p (foreign-alloc '(:struct struct-pair))))
(translate-into-foreign-memory object type p)
(values p t)))
(defmethod free-translated-object (pointer (type pair) freep)
(when freep
(foreign-free pointer)))
(deftest struct-values.translation.1
(multiple-value-bind (p freep)
(convert-to-foreign '(1 . 2) 'struct-pair)
(assert freep)
(unwind-protect
(convert-from-foreign p 'struct-pair)
(free-converted-object p 'struct-pair freep)))
(1 . 2))
(defcfun "pair_pointer_sum" :int
(p (:pointer (:struct struct-pair))))
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.2
(pair-pointer-sum '(1 . 2))
3)
;;; should the return type be something along the lines of
;;; (:pointer (:struct pair) :free t)?
;;; LMH: error on ":free t" option?
(defcfun "alloc_pair" (:pointer (:struct struct-pair))
(a :int)
(b :int))
;; bogus: doesn't free() pointer.
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.3
(alloc-pair 1 2)
(1 . 2))
(deftest struct-values.translation.mem-ref.1
(with-foreign-object (p '(:struct struct-pair))
(setf (mem-ref p '(:struct struct-pair)) '(1 . 2))
(with-foreign-slots ((a b) p (:struct struct-pair))
(values (mem-ref p '(:struct struct-pair))
a
b)))
(1 . 2)
1
2)
(deftest struct-values.translation.mem-aref.1
(with-foreign-object (p '(:struct struct-pair) 2)
(setf (mem-aref p '(:struct struct-pair) 0) '(1 . 2)
(mem-aref p '(:struct struct-pair) 1) '(3 . 4))
(values (mem-aref p '(:struct struct-pair) 0)
(mem-aref p '(:struct struct-pair) 1)))
(1 . 2)
(3 . 4))
(defcstruct (struct-pair-default-translate :class pair-default)
(a :int)
(b :int))
(deftest struct-values-default.translation.mem-ref.1
(with-foreign-object (p '(:struct struct-pair-default-translate))
(setf (mem-ref p '(:struct struct-pair-default-translate)) '(a 1 b 2))
(with-foreign-slots ((a b) p (:struct struct-pair-default-translate))
(let ((plist (mem-ref p '(:struct struct-pair-default-translate))))
(values (getf plist 'a)
(getf plist 'b)
a
b))))
1
2
1
2)
(defcstruct (struct-pair+double :class pair+double)
(pr (:struct struct-pair-default-translate))
(dbl :double))
(deftest struct-values-default.translation.mem-ref.2
(with-foreign-object (p '(:struct struct-pair+double))
(setf (mem-ref p '(:struct struct-pair+double)) '(pr (a 4 b 5) dbl 2.5d0))
(with-foreign-slots ((pr dbl) p (:struct struct-pair+double))
(let ((plist (mem-ref p '(:struct struct-pair+double))))
(values (getf (getf plist 'pr) 'a)
(getf (getf plist 'pr) 'b)
(getf plist 'dbl)))))
4
5
2.5d0)
(defcstruct (struct-pair+1 :class pair+1)
(p (:pointer (:struct struct-pair)))
(c :int))
(defctype struct-pair+1 (:struct struct-pair+1))
(defmethod translate-from-foreign (pointer (type pair+1))
(with-foreign-slots ((p c) pointer struct-pair+1)
(cons p c)))
(defmethod translate-into-foreign-memory (object (type pair+1) pointer)
(with-foreign-slots ((c) pointer struct-pair+1)
(convert-into-foreign-memory (car object)
'struct-pair
(foreign-slot-pointer pointer
'struct-pair+1
'p))
(setf c (cdr object))))
(defmethod translate-to-foreign (object (type pair+1))
(let ((p (foreign-alloc 'struct-pair+1)))
(translate-into-foreign-memory object type p)
(values p t)))
(defmethod free-translated-object (pointer (type pair+1) freep)
(when freep
(foreign-free pointer)))
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.1
(multiple-value-bind (p freep)
(convert-to-foreign '((1 . 2) . 3) 'struct-pair+1)
(assert freep)
(unwind-protect
(convert-from-foreign p 'struct-pair+1)
(free-converted-object p 'struct-pair+1 freep)))
((1 . 2) . 3))
#+#:unimplemented
(defcfun "pair_plus_one_sum" :int
(p (:struct pair+1)))
(defcfun "pair_plus_one_pointer_sum" :int
(p (:pointer (:struct struct-pair+1))))
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.2
(pair-plus-one-pointer-sum '((1 . 2) . 3))
6)
#+#:unimplemented
(defcfun "make_pair_plus_one" (:struct pair+1)
(a :int)
(b :int)
(c :int))
(defcfun "alloc_pair_plus_one" struct-pair+1
(a :int)
(b :int)
(c :int))
;; bogus: doesn't free() pointer.
#+#:pointer-translation-not-yet-implemented
(deftest struct-values.translation.ppo.3
(alloc-pair-plus-one 1 2 3)
((1 . 2) . 3))
#+#:unimplemented
(defcfun "pair_sum" :int
(p (:struct pair)))
#+#:unimplemented
(defcfun "make_pair" (:struct pair)
(a :int)
(b :int))
#|| ; TODO: load cffi-libffi for these tests to work.
(deftest struct-values.fn.1
(with-foreign-object (p '(:struct pair))
(with-foreign-slots ((a b) p (:struct pair))
(setf a -1 b 2)
(pair-sum p)))
1)
(deftest struct-values.fn.2
(pair-sum '(3 . 5))
8)
(deftest struct-values.fn.3
(with-foreign-object (p '(:struct pair))
(make-pair 7 11 :result-pointer p)
(with-foreign-slots ((a b) p (:struct pair))
(cons a b)))
(7 . 11))
(deftest struct-values.fn.4
(make-pair 13 17)
(13 . 17))
||#
(defcstruct single-byte-struct
(a :uint8))
(deftest bare-struct-types.1
(eql (foreign-type-size 'single-byte-struct)
(foreign-type-size '(:struct single-byte-struct)))
t)
(defctype single-byte-struct-alias (:struct single-byte-struct))
(deftest bare-struct-types.2
(eql (foreign-type-size 'single-byte-struct-alias)
(foreign-type-size '(:struct single-byte-struct)))
t)
;;; Old-style access to inner structure fields.
(defcstruct inner-struct (x :int))
(defcstruct old-style-outer (inner inner-struct))
(defcstruct new-style-outer (inner (:struct inner-struct)))
(deftest old-style-struct-access
(with-foreign-object (s '(:struct old-style-outer))
(let ((inner-ptr (foreign-slot-pointer s 'old-style-outer 'inner)))
(setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
(assert (pointerp (foreign-slot-value s 'old-style-outer 'inner)))
(foreign-slot-value (foreign-slot-value s 'old-style-outer 'inner)
'inner-struct 'x))
42)
(deftest new-style-struct-access
(with-foreign-object (s '(:struct new-style-outer))
(let ((inner-ptr (foreign-slot-pointer s 'new-style-outer 'inner)))
(setf (foreign-slot-value inner-ptr 'inner-struct 'x) 42))
(foreign-slot-value s 'new-style-outer 'inner))
(x 42))
;;; regression test: setting the value of aggregate slots.
(defcstruct aggregate-struct
(x :int)
(pair (:struct struct-pair))
(y :int))
(deftest set-aggregate-struct-slot
(with-foreign-objects ((pair-struct '(:struct struct-pair))
(aggregate-struct '(:struct aggregate-struct)))
(with-foreign-slots ((a b) pair-struct (:struct struct-pair))
(setf a 1 b 2)
(with-foreign-slots ((x pair y) aggregate-struct (:struct aggregate-struct))
(setf x 42 y 42)
(setf pair pair-struct)
(values x pair y))))
42
(1 . 2)
42)
;; TODO this needs to go through compile-file to exhibit the error
;; ("don't know how to dump #<CFFI::AGGREGATE-STRUCT-SLOT>"), but
;; there's no support for that, so let's leave it at toplevel here.
(defcstruct (aggregate-struct.acc :conc-name acc-)
(x :int)
(pair (:struct struct-pair))
(y :int))
(deftest set-aggregate-struct-slot.acc
(with-foreign-objects ((pair-struct '(:struct struct-pair))
(aggregate-struct '(:struct aggregate-struct)))
(with-foreign-slots ((a b) pair-struct (:struct struct-pair))
(setf a 1 b 2)
(setf (acc-x aggregate-struct) 42)
(setf (acc-y aggregate-struct) 42)
(setf (acc-pair aggregate-struct) pair-struct)
(values (acc-x aggregate-struct)
(acc-pair aggregate-struct)
(acc-y aggregate-struct))))
42
(1 . 2)
42)

42
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/test-asdf.lisp Normal file
View file

@ -0,0 +1,42 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; asdf.lisp --- CFFI-Grovel asdf support tests.
;;;
;;; Copyright (C) 2015, 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)
#.(when (cffi-toolchain::static-ops-enabled-p)
'(deftest test-static-program
(progn
(asdf:operate :static-program-op :cffi-tests/example)
(let ((program (asdf:output-file :static-program-op :cffi-tests/example)))
(uiop:run-program `(,(native-namestring program) "1" "2 3") :output :lines)))
("Arguments: 1 \"2 3\"" "hello, world!") nil 0))
(deftest test-asdf-load
(progn
(asdf:load-system :cffi-tests/example)
(uiop:symbol-call :cffi-example :check-groveller))
nil)

9
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/test-static-link.sh Normal file
View file

@ -0,0 +1,9 @@
#!/bin/sh -eux
for l in sbcl ; do # mkcl ecl clisp sbcl
EX="$(cl-launch -l $l -sp cffi-toolchain -ip "(output-file :static-program-op :cffi-tests/example)")"
rm -f $EX ; :
cl-launch -l $l -sp cffi-toolchain -i "(operate :static-program-op :cffi-tests/example)"
[ -f $EX ]
[ "$($EX)" = "hello, world!" ]
done

52
sbcl/.quicklisp/dists/quicklisp/software/cffi_0.20.1/tests/union.lisp Normal file
View file

@ -0,0 +1,52 @@
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; union.lisp --- Tests on C unions.
;;;
;;; Copyright (C) 2005-2006, James Bielman <jamesjb@jamesjb.com>
;;;
;;; 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)
(defcunion uint32-bytes
(int-value :unsigned-int)
(bytes :unsigned-char :count 4))
(defctype uint32-bytes (:union uint32-bytes))
(defun int-to-bytes (n)
"Convert N to a list of bytes using a union."
(with-foreign-object (obj 'uint32-bytes)
(setf (foreign-slot-value obj 'uint32-bytes 'int-value) n)
(loop for i from 0 below 4
collect (mem-aref
(foreign-slot-value obj 'uint32-bytes 'bytes)
:unsigned-char i))))
(deftest union.1
(let ((bytes (int-to-bytes #x12345678)))
(cond ((equal bytes '(#x12 #x34 #x56 #x78))
t)
((equal bytes '(#x78 #x56 #x34 #x12))
t)
(t bytes)))
t)