mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-18 18:40:22 +02:00
5b46a8c2c8
* libguile/foreign.h (scm_t_foreign_finalizer): Rename to... (scm_t_pointer_finalizer): ... this. (SCM_FOREIGN_P): Rename to... (SCM_POINTER_P): this. (SCM_VALIDATE_FOREIGN): Rename to... (SCM_VALIDATE_POINTER): ... this. (SCM_FOREIGN_HAS_FINALIZER): Rename to... (SCM_POINTER_HAS_FINALIZER): ... this. (scm_take_foreign_pointer): Rename to... (scm_from_pointer): ... this. (scm_foreign_address): Rename to... (scm_pointer_address): ... this. (scm_foreign_to_bytevector): Rename to... (scm_pointer_to_bytevector): ... this. (scm_foreign_set_finalizer_x): Rename to... (scm_set_pointer_finalizer_x): ... this. (scm_bytevector_to_foreign): Rename to... (scm_bytevector_to_pointer): ... this. (scm_i_foreign_print): Rename to... (scm_i_pointer_print): ... this. * libguile/foreign.c: Update accordingly. * libguile/tags.h (scm_tc7_foreign): Rename to... (scm_tc7_pointer): ... this. * libguile/foreign.c, libguile/deprecated.c, libguile/dynl.c, libguile/evalext.c, libguile/gc.c, libguile/goops.c, libguile/gsubr.c, libguile/gsubr.h, libguile/print.c, libguile/snarf.h, libguile/vm-i-system.c, module/system/foreign.scm, test-suite/standalone/test-ffi, test-suite/tests/foreign.test: Update accordingly.
208 lines
5.8 KiB
Scheme
Executable file
208 lines
5.8 KiB
Scheme
Executable file
#!/bin/sh
|
||
exec guile -q -s "$0" "$@"
|
||
!#
|
||
|
||
(use-modules (system foreign)
|
||
(rnrs bytevectors))
|
||
|
||
(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-
|
||
(make-foreign-function void (dynamic-func "test_ffi_v_" lib) '()))
|
||
(test (f-v-) *unspecified*)
|
||
|
||
(define f-s8-
|
||
(make-foreign-function int8 (dynamic-func "test_ffi_s8_" lib) '()))
|
||
(test (f-s8-) -100)
|
||
|
||
(define f-u8-
|
||
(make-foreign-function uint8 (dynamic-func "test_ffi_u8_" lib) '()))
|
||
(test (f-u8-) 200)
|
||
|
||
(define f-s16-
|
||
(make-foreign-function int16 (dynamic-func "test_ffi_s16_" lib) '()))
|
||
(test (f-s16-) -20000)
|
||
|
||
(define f-u16-
|
||
(make-foreign-function uint16 (dynamic-func "test_ffi_u16_" lib) '()))
|
||
(test (f-u16-) 40000)
|
||
|
||
(define f-s32-
|
||
(make-foreign-function int32 (dynamic-func "test_ffi_s32_" lib) '()))
|
||
(test (f-s32-) -2000000000)
|
||
|
||
(define f-u32-
|
||
(make-foreign-function uint32 (dynamic-func "test_ffi_u32_" lib) '()))
|
||
(test (f-u32-) 4000000000)
|
||
|
||
(define f-s64-
|
||
(make-foreign-function int64 (dynamic-func "test_ffi_s64_" lib) '()))
|
||
(test (f-s64-) -2000000000)
|
||
|
||
(define f-u64-
|
||
(make-foreign-function uint64 (dynamic-func "test_ffi_u64_" lib) '()))
|
||
(test (f-u64-) 4000000000)
|
||
|
||
;;;
|
||
;;; One u8 arg
|
||
;;;
|
||
(define f-v-u8
|
||
(make-foreign-function void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
|
||
(test (f-v-u8 10) *unspecified*)
|
||
|
||
(define f-s8-u8
|
||
(make-foreign-function int8 (dynamic-func "test_ffi_s8_u8" lib) (list uint8)))
|
||
(test (f-s8-u8 10) -90)
|
||
|
||
(define f-u8-u8
|
||
(make-foreign-function uint8 (dynamic-func "test_ffi_u8_u8" lib) (list uint8)))
|
||
(test (f-u8-u8 10) 210)
|
||
|
||
(define f-s16-u8
|
||
(make-foreign-function int16 (dynamic-func "test_ffi_s16_u8" lib) (list uint8)))
|
||
(test (f-s16-u8 10) -19990)
|
||
|
||
(define f-u16-u8
|
||
(make-foreign-function uint16 (dynamic-func "test_ffi_u16_u8" lib) (list uint8)))
|
||
(test (f-u16-u8 10) 40010)
|
||
|
||
(define f-s32-u8
|
||
(make-foreign-function int32 (dynamic-func "test_ffi_s32_u8" lib) (list uint8)))
|
||
(test (f-s32-u8 10) -1999999990)
|
||
|
||
(define f-u32-u8
|
||
(make-foreign-function uint32 (dynamic-func "test_ffi_u32_u8" lib) (list uint8)))
|
||
(test (f-u32-u8 10) 4000000010)
|
||
|
||
(define f-s64-u8
|
||
(make-foreign-function int64 (dynamic-func "test_ffi_s64_u8" lib) (list uint8)))
|
||
(test (f-s64-u8 10) -1999999990)
|
||
|
||
(define f-u64-u8
|
||
(make-foreign-function uint64 (dynamic-func "test_ffi_u64_u8" lib) (list uint8)))
|
||
(test (f-u64-u8 10) 4000000010)
|
||
|
||
|
||
;;;
|
||
;;; One s64 arg
|
||
;;;
|
||
(define f-v-s64
|
||
(make-foreign-function void (dynamic-func "test_ffi_v_s64" lib) (list int64)))
|
||
(test (f-v-s64 10) *unspecified*)
|
||
|
||
(define f-s8-s64
|
||
(make-foreign-function int8 (dynamic-func "test_ffi_s8_s64" lib) (list int64)))
|
||
(test (f-s8-s64 10) -90)
|
||
|
||
(define f-u8-s64
|
||
(make-foreign-function uint8 (dynamic-func "test_ffi_u8_s64" lib) (list int64)))
|
||
(test (f-u8-s64 10) 210)
|
||
|
||
(define f-s16-s64
|
||
(make-foreign-function int16 (dynamic-func "test_ffi_s16_s64" lib) (list int64)))
|
||
(test (f-s16-s64 10) -19990)
|
||
|
||
(define f-u16-s64
|
||
(make-foreign-function uint16 (dynamic-func "test_ffi_u16_s64" lib) (list int64)))
|
||
(test (f-u16-s64 10) 40010)
|
||
|
||
(define f-s32-s64
|
||
(make-foreign-function int32 (dynamic-func "test_ffi_s32_s64" lib) (list int64)))
|
||
(test (f-s32-s64 10) -1999999990)
|
||
|
||
(define f-u32-s64
|
||
(make-foreign-function uint32 (dynamic-func "test_ffi_u32_s64" lib) (list int64)))
|
||
(test (f-u32-s64 10) 4000000010)
|
||
|
||
(define f-s64-s64
|
||
(make-foreign-function int64 (dynamic-func "test_ffi_s64_s64" lib) (list int64)))
|
||
(test (f-s64-s64 10) -1999999990)
|
||
|
||
(define f-u64-s64
|
||
(make-foreign-function 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
|
||
(make-foreign-function int64 (dynamic-func "test_ffi_sum" lib)
|
||
(list int8 int16 int32 int64)))
|
||
(test (f-sum -1 2000 -30000 40000000000)
|
||
(+ -1 2000 -30000 40000000000))
|
||
|
||
;;
|
||
;; Structs
|
||
;;
|
||
(define f-sum-struct
|
||
(make-foreign-function 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
|
||
(make-foreign-function '* (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")))
|
||
|
||
|
||
;;;
|
||
;;; Global symbols.
|
||
;;;
|
||
|
||
(use-modules ((rnrs bytevectors) #:select (utf8->string)))
|
||
|
||
(if (defined? 'setlocale)
|
||
(setlocale LC_ALL "C"))
|
||
|
||
(define global (dynamic-link))
|
||
|
||
(define strerror
|
||
(make-foreign-function '* (dynamic-func "strerror" global)
|
||
(list int)))
|
||
|
||
(define strlen
|
||
(make-foreign-function 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:
|