summaryrefslogtreecommitdiff
path: root/test-suite/standalone/test-ffi
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/standalone/test-ffi')
-rwxr-xr-xtest-suite/standalone/test-ffi294
1 files changed, 294 insertions, 0 deletions
diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi
new file mode 100755
index 000000000..0e6ab45d1
--- /dev/null
+++ b/test-suite/standalone/test-ffi
@@ -0,0 +1,294 @@
+#!/bin/sh
+exec guile -q -s "$0" "$@"
+!#
+;;; test-ffi --- Foreign function interface. -*- Scheme -*-
+;;;
+;;; Copyright (C) 2010, 2017 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(use-modules (system foreign)
+ (rnrs bytevectors)
+ (srfi srfi-1)
+ (srfi srfi-26))
+
+(define lib
+ (dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))
+
+(define failed? #f)
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ exp res)
+ (let ((expected res)
+ (actual exp))
+ (if (not (equal? actual expected))
+ (begin
+ (set! failed? #t)
+ (format (current-error-port)
+ "bad return from expression `~a': expected ~A; got ~A~%"
+ 'exp expected actual)))))))
+
+;;;
+;;; No args
+;;;
+(define f-v-
+ (pointer->procedure void (dynamic-func "test_ffi_v_" lib) '()))
+(test (f-v-) *unspecified*)
+
+(define f-s8-
+ (pointer->procedure int8 (dynamic-func "test_ffi_s8_" lib) '()))
+(test (f-s8-) -100)
+
+(define f-u8-
+ (pointer->procedure uint8 (dynamic-func "test_ffi_u8_" lib) '()))
+(test (f-u8-) 200)
+
+(define f-s16-
+ (pointer->procedure int16 (dynamic-func "test_ffi_s16_" lib) '()))
+(test (f-s16-) -20000)
+
+(define f-u16-
+ (pointer->procedure uint16 (dynamic-func "test_ffi_u16_" lib) '()))
+(test (f-u16-) 40000)
+
+(define f-s32-
+ (pointer->procedure int32 (dynamic-func "test_ffi_s32_" lib) '()))
+(test (f-s32-) -2000000000)
+
+(define f-u32-
+ (pointer->procedure uint32 (dynamic-func "test_ffi_u32_" lib) '()))
+(test (f-u32-) 4000000000)
+
+(define f-s64-
+ (pointer->procedure int64 (dynamic-func "test_ffi_s64_" lib) '()))
+(test (f-s64-) -2000000000)
+
+(define f-u64-
+ (pointer->procedure uint64 (dynamic-func "test_ffi_u64_" lib) '()))
+(test (f-u64-) 4000000000)
+
+;;;
+;;; One u8 arg
+;;;
+(define f-v-u8
+ (pointer->procedure void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
+(test (f-v-u8 10) *unspecified*)
+
+(define f-s8-u8
+ (pointer->procedure int8 (dynamic-func "test_ffi_s8_u8" lib) (list uint8)))
+(test (f-s8-u8 10) -90)
+
+(define f-u8-u8
+ (pointer->procedure uint8 (dynamic-func "test_ffi_u8_u8" lib) (list uint8)))
+(test (f-u8-u8 10) 210)
+
+(define f-s16-u8
+ (pointer->procedure int16 (dynamic-func "test_ffi_s16_u8" lib) (list uint8)))
+(test (f-s16-u8 10) -19990)
+
+(define f-u16-u8
+ (pointer->procedure uint16 (dynamic-func "test_ffi_u16_u8" lib) (list uint8)))
+(test (f-u16-u8 10) 40010)
+
+(define f-s32-u8
+ (pointer->procedure int32 (dynamic-func "test_ffi_s32_u8" lib) (list uint8)))
+(test (f-s32-u8 10) -1999999990)
+
+(define f-u32-u8
+ (pointer->procedure uint32 (dynamic-func "test_ffi_u32_u8" lib) (list uint8)))
+(test (f-u32-u8 10) 4000000010)
+
+(define f-s64-u8
+ (pointer->procedure int64 (dynamic-func "test_ffi_s64_u8" lib) (list uint8)))
+(test (f-s64-u8 10) -1999999990)
+
+(define f-u64-u8
+ (pointer->procedure uint64 (dynamic-func "test_ffi_u64_u8" lib) (list uint8)))
+(test (f-u64-u8 10) 4000000010)
+
+
+;;;
+;;; One s64 arg
+;;;
+(define f-v-s64
+ (pointer->procedure void (dynamic-func "test_ffi_v_s64" lib) (list int64)))
+(test (f-v-s64 10) *unspecified*)
+
+(define f-s8-s64
+ (pointer->procedure int8 (dynamic-func "test_ffi_s8_s64" lib) (list int64)))
+(test (f-s8-s64 10) -90)
+
+(define f-u8-s64
+ (pointer->procedure uint8 (dynamic-func "test_ffi_u8_s64" lib) (list int64)))
+(test (f-u8-s64 10) 210)
+
+(define f-s16-s64
+ (pointer->procedure int16 (dynamic-func "test_ffi_s16_s64" lib) (list int64)))
+(test (f-s16-s64 10) -19990)
+
+(define f-u16-s64
+ (pointer->procedure uint16 (dynamic-func "test_ffi_u16_s64" lib) (list int64)))
+(test (f-u16-s64 10) 40010)
+
+(define f-s32-s64
+ (pointer->procedure int32 (dynamic-func "test_ffi_s32_s64" lib) (list int64)))
+(test (f-s32-s64 10) -1999999990)
+
+(define f-u32-s64
+ (pointer->procedure uint32 (dynamic-func "test_ffi_u32_s64" lib) (list int64)))
+(test (f-u32-s64 10) 4000000010)
+
+(define f-s64-s64
+ (pointer->procedure int64 (dynamic-func "test_ffi_s64_s64" lib) (list int64)))
+(test (f-s64-s64 10) -1999999990)
+
+(define f-u64-s64
+ (pointer->procedure uint64 (dynamic-func "test_ffi_u64_s64" lib) (list int64)))
+(test (f-u64-s64 10) 4000000010)
+
+
+;;
+;; Multiple int args of differing types
+;;
+(define f-sum
+ (pointer->procedure int64 (dynamic-func "test_ffi_sum" lib)
+ (list int8 int16 int32 int64)))
+(test (f-sum -1 2000 -30000 40000000000)
+ (+ -1 2000 -30000 40000000000))
+
+;;
+;; More than ten arguments
+;;
+(define f-sum-many
+ (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib)
+ (list uint8 uint16 uint32 uint64
+ int8 int16 int32 int64
+ int8 int16 int32 int64)))
+(test (f-sum-many 255 65535 4294967295 1844674407370955161
+ -1 2000 -30000 40000000000
+ 5 -6000 70000 -80000000000)
+ (+ 255 65535 4294967295 1844674407370955161
+ -1 2000 -30000 40000000000
+ 5 -6000 70000 -80000000000))
+
+;;
+;; Structs
+;;
+(define f-sum-struct
+ (pointer->procedure int64 (dynamic-func "test_ffi_sum_struct" lib)
+ (list (list int8 int16 int32 int64))))
+(test (f-sum-struct (make-c-struct (list int8 int16 int32 int64)
+ (list -1 2000 -30000 40000000000)))
+ (+ -1 2000 -30000 40000000000))
+;;
+;; Structs
+;;
+(define f-memcpy
+ (pointer->procedure '* (dynamic-func "test_ffi_memcpy" lib)
+ (list '* '* int32)))
+(let* ((src* '(0 1 2 3 4 5 6 7))
+ (src (bytevector->pointer (u8-list->bytevector src*)))
+ (dest (bytevector->pointer (make-bytevector 16 0)))
+ (res (f-memcpy dest src (length src*))))
+ (or (= (pointer-address dest) (pointer-address res))
+ (error "memcpy res not equal to dest"))
+ (or (equal? (bytevector->u8-list (pointer->bytevector dest 16))
+ '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
+ (error "unexpected dest")))
+
+;;
+;; Function pointers
+;;
+
+(define f-callback-1
+ (pointer->procedure int (dynamic-func "test_ffi_callback_1" lib)
+ (list '* int)))
+
+(if (defined? 'procedure->pointer)
+ (let* ((calls 0)
+ (ptr (procedure->pointer int
+ (lambda (x)
+ (set! calls (+ 1 calls))
+ (* x 3))
+ (list int)))
+ (input (iota 123)))
+ (define (expected-result x)
+ (+ 7 (* x 3)))
+
+ (let ((result (map (cut f-callback-1 ptr <>) input)))
+ (and (or (= calls (length input))
+ (error "incorrect number of callback calls" calls))
+ (or (equal? (map expected-result input) result)
+ (error "incorrect result" result))))))
+
+(define f-callback-2
+ (pointer->procedure double (dynamic-func "test_ffi_callback_2" lib)
+ (list '* float int double)))
+
+(if (defined? 'procedure->pointer)
+ (let* ((proc (lambda (x y z)
+ (* (+ x (exact->inexact y)) z)))
+ (ptr (procedure->pointer double proc
+ (list float int double)))
+ (arg1 (map (cut * <> 1.25) (iota 123 500)))
+ (arg2 (iota 123))
+ (arg3 (map (cut / <> 2.0) (iota 123 0 -10))))
+ (define result
+ (map (cut f-callback-2 ptr <> <> <>)
+ arg1 arg2 arg3))
+
+ (or (equal? result (map proc arg1 arg2 arg3))
+ (error "incorrect result" result))))
+
+
+;;;
+;;; Global symbols.
+;;;
+
+(use-modules ((rnrs bytevectors) #:select (utf8->string)))
+
+(if (defined? 'setlocale)
+ (setlocale LC_ALL "C"))
+
+(define global (cond
+ ((string-contains %host-type "cygwin")
+ ;; On Cygwin, dynamic-link doesn't search recursively
+ ;; into linked DLLs. Thus one needs to link to the core
+ ;; C library DLL explicitly.
+ (dynamic-link "cygwin1"))
+ (else
+ (dynamic-link))))
+
+
+(define strerror
+ (pointer->procedure '* (dynamic-func "strerror" global)
+ (list int)))
+
+(define strlen
+ (pointer->procedure size_t (dynamic-func "strlen" global)
+ (list '*)))
+
+(let* ((ptr (strerror ENOENT))
+ (len (strlen ptr))
+ (bv (pointer->bytevector ptr len 0 'u8))
+ (str (utf8->string bv)))
+ (test #t (not (not (string-contains str "file")))))
+
+(exit (not failed?))
+
+;; Local Variables:
+;; mode: scheme
+;; End: