mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
fa2a89a6d1
* libguile/foreign.c (scm_string_to_pointer, scm_pointer_to_string): New
functions.
* libguile/foreign.h (scm_string_to_pointer, scm_pointer_to_string): New
declarations.
* module/system/foreign.scm: Export `string->pointer' and
`pointer->string'.
* test-suite/tests/foreign.test ("pointer<->string"): New test prefix.
* doc/ref/api-foreign.texi (Void Pointers and Byte Access): Add
`string->pointer' and `pointer->string'.
101 lines
3.1 KiB
Scheme
101 lines
3.1 KiB
Scheme
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
|
||
;;;;
|
||
;;;; 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
|
||
|
||
;;;
|
||
;;; See also ../standalone/test-ffi for FFI tests.
|
||
;;;
|
||
|
||
(define-module (test-foreign)
|
||
#:use-module (system foreign)
|
||
#:use-module (rnrs bytevectors)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (test-suite lib))
|
||
|
||
|
||
(with-test-prefix "null pointer"
|
||
|
||
(pass-if "zero"
|
||
(= 0 (pointer-address %null-pointer)))
|
||
|
||
(pass-if "null pointer identity"
|
||
(eq? %null-pointer (make-pointer 0)))
|
||
|
||
(pass-if "null-pointer? %null-pointer"
|
||
(null-pointer? %null-pointer))
|
||
|
||
(pass-if-exception "pointer->bytevector %null-pointer"
|
||
exception:null-pointer-error
|
||
(pointer->bytevector %null-pointer 7)))
|
||
|
||
|
||
(with-test-prefix "make-pointer"
|
||
|
||
(pass-if "address preserved"
|
||
(= 123 (pointer-address (make-pointer 123)))))
|
||
|
||
|
||
(with-test-prefix "pointer<->bytevector"
|
||
|
||
(pass-if "bijection"
|
||
(let ((bv #vu8(0 1 2 3 4 5 6 7)))
|
||
(equal? (pointer->bytevector (bytevector->pointer bv)
|
||
(bytevector-length bv))
|
||
bv)))
|
||
|
||
(pass-if "pointer from bits"
|
||
(let* ((bytes (iota (sizeof '*)))
|
||
(bv (u8-list->bytevector bytes)))
|
||
(= (pointer-address
|
||
(make-pointer (bytevector-uint-ref bv 0 (native-endianness)
|
||
(sizeof '*))))
|
||
(fold-right (lambda (byte address)
|
||
(+ byte (* 256 address)))
|
||
0
|
||
bytes))))
|
||
|
||
(pass-if "dereference-pointer"
|
||
(let* ((bytes (iota (sizeof '*)))
|
||
(bv (u8-list->bytevector bytes)))
|
||
(= (pointer-address
|
||
(dereference-pointer (bytevector->pointer bv)))
|
||
(fold-right (lambda (byte address)
|
||
(+ byte (* 256 address)))
|
||
0
|
||
bytes)))))
|
||
|
||
|
||
(with-test-prefix "pointer<->string"
|
||
|
||
(pass-if "bijection"
|
||
(let ((s "hello, world"))
|
||
(string=? s (pointer->string (string->pointer s)))))
|
||
|
||
(pass-if "bijection [latin1]"
|
||
(with-latin1-locale
|
||
(let ((s "Szép jó napot!"))
|
||
(string=? s (pointer->string (string->pointer s)))))))
|
||
|
||
|
||
(with-test-prefix "structs"
|
||
|
||
(pass-if "parse-c-struct"
|
||
(let ((layout (list int64 uint8))
|
||
(data (list -300 43)))
|
||
(equal? (parse-c-struct (make-c-struct layout data)
|
||
layout)
|
||
data))))
|