mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 11:50:28 +02:00
5ccc3764b3
* libguile/foreign.c (OBJCODE_HEADER, META_HEADER, META): Change these into higher-order macros. (GEN_CODE): New higher-order macro based on 'CODE'. (M_STATIC, M_DYNAMIC): New macros. (CODE): Reimplement using 'GEN_CODE' and 'M_STATIC'. (make_objcode_trampoline): New static function. (large_objcode_trampolines, large_objcode_trampolines_mutex): New static variables. (get_objcode_trampoline): New static function. (cif_to_procedure): Use 'get_objcode_trampoline'. * test-suite/standalone/test-ffi-lib.c (test_ffi_sum_many): New function. * test-suite/standalone/test-ffi: Add test.
286 lines
8.6 KiB
Scheme
Executable file
286 lines
8.6 KiB
Scheme
Executable file
#!/bin/sh
|
||
exec guile -q -s "$0" "$@"
|
||
!#
|
||
;;; test-ffi --- Foreign function interface. -*- Scheme -*-
|
||
;;;
|
||
;;; Copyright (C) 2010 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 (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:
|