mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-29 06:20:30 +02:00
d4149a510e
Suggested by Neil Jerram.
* libguile/foreign.h (SCM_FOREIGN_TYPE, SCM_FOREIGN_VALUE_REF,
SCM_FOREIGN_VALUE_SET, SCM_FOREIGN_LEN, SCM_FOREIGN_TYPED_P,
SCM_FOREIGN_VALUE_P, SCM_VALIDATE_FOREIGN_VALUE, scm_foreign_set_x,
scm_foreign_type): Remove.
(scm_foreign_ref): Rename to...
(scm_foreign_address): ... this.
(scm_take_foreign_pointer): Update.
(SCM_FOREIGN_POINTER): Remove CTYPE argument. Update callers.
(scm_make_pointer): New declaration.
* libguile/foreign.c (scm_to_uintptr, scm_from_uintptr): New macros.
(scm_make_pointer): New function.
(scm_take_foreign_pointer): Remove TYPE and LEN arguments. Update
callers.
(scm_foreign_ref): Remove to...
(scm_foreign_address): ... this. Remove type-related code.
(scm_foreign_set_x): Remove.
(scm_foreign_to_bytevector): Change argument order; make LEN argument
compulsory.
(scm_i_foreign_print): Remove type printing.
(unpack): Remove foreign-type checking.
* libguile/deprecated.c (scm_dynamic_args_call): Update accordingly.
* libguile/dynl.c (scm_dynamic_pointer): Remove the TYPE and LEN
arguments; update callers. Update to the new foreign API.
* libguile/dynl.h (scm_dynamic_pointer): Update.
* libguile/gsubr.c (create_gsubr): Update to the new foreign API.
* libguile/gsubr.h (SCM_SUBRF, SCM_SUBR_GENERIC): Ditto.
* libguile/snarf.h (SCM_IMMUTABLE_FOREIGN): Ditto.
* libguile/vm-i-system.c (subr_call): Ditto.
* module/system/foreign.scm (null-pointer?): New procedure.
* test-suite/standalone/test-ffi: Update to the new
`bytevector->foreign' signature.
* test-suite/tests/foreign.test ("null pointer")["null pointer
identity", "null-pointer? %null-pointer"]: New tests.
["foreign-set! other-null-pointer", "foreign->bytevector
other-null-pointer"]: Remove.
("make-pointer", "foreign<->bytevector"): New test prefixes.
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->foreign (u8-list->bytevector src*)))
|
||
(dest (bytevector->foreign (make-bytevector 16 0)))
|
||
(res (f-memcpy dest src (length src*))))
|
||
(or (= (foreign-address dest) (foreign-address res))
|
||
(error "memcpy res not equal to dest"))
|
||
(or (equal? (bytevector->u8-list (foreign->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 (foreign->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:
|