diff options
Diffstat (limited to 'test-suite/standalone/test-ffi')
-rwxr-xr-x | test-suite/standalone/test-ffi | 294 |
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: |