test-suite/tests/foreign.test

   1 ;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;;
  20 ;;; See also ../standalone/test-ffi for FFI tests.
  21 ;;;
  22
  23 (define-module (test-foreign)
  24   #:use-module (system foreign)
  25   #:use-module (rnrs bytevectors)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (test-suite lib))
  28
  29 \f
  30 (with-test-prefix "null pointer"
  31
  32   (pass-if "zero"
  33     (= 0 (foreign-address %null-pointer)))
  34
  35   (pass-if "null pointer identity"
  36     (eq? %null-pointer (make-pointer 0)))
  37
  38   (pass-if "null-pointer? %null-pointer"
  39     (null-pointer? %null-pointer))
  40
  41   (pass-if-exception "foreign->bytevector %null-pointer"
  42     exception:null-pointer-error
  43     (foreign->bytevector %null-pointer 7)))
  44
  45 \f
  46 (with-test-prefix "make-pointer"
  47
  48   (pass-if "address preserved"
  49     (= 123 (foreign-address (make-pointer 123)))))
  50
  51 \f
  52 (with-test-prefix "foreign<->bytevector"
  53
  54   (pass-if "bijection"
  55     (let ((bv #vu8(0 1 2 3 4 5 6 7)))
  56       (equal? (foreign->bytevector (bytevector->foreign bv)
  57                                    (bytevector-length bv))
  58               bv)))
  59
  60   (pass-if "pointer from bits"
  61     (let* ((bytes (iota (sizeof '*)))
  62            (bv    (u8-list->bytevector bytes)))
  63       (= (foreign-address
  64           (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
  65                                              (sizeof '*))))
  66          (fold-right (lambda (byte address)
  67                        (+ byte (* 256 address)))
  68                      0
  69                      bytes))))
  70
  71   (pass-if "dereference-pointer"
  72     (let* ((bytes (iota (sizeof '*)))
  73            (bv    (u8-list->bytevector bytes)))
  74       (= (foreign-address
  75           (dereference-pointer (bytevector->foreign bv)))
  76          (fold-right (lambda (byte address)
  77                        (+ byte (* 256 address)))
  78                      0
  79                      bytes)))))