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 (srfi srfi-26)
  28   #:use-module (test-suite lib))
  29
  30 \f
  31 (with-test-prefix "null pointer"
  32
  33   (pass-if "zero"
  34     (= 0 (pointer-address %null-pointer)))
  35
  36   (pass-if "null pointer identity"
  37     (eq? %null-pointer (make-pointer 0)))
  38
  39   (pass-if "null-pointer? %null-pointer"
  40     (null-pointer? %null-pointer))
  41
  42   (pass-if-exception "pointer->bytevector %null-pointer"
  43     exception:null-pointer-error
  44     (pointer->bytevector %null-pointer 7)))
  45
  46 \f
  47 (with-test-prefix "make-pointer"
  48
  49   (pass-if "address preserved"
  50     (= 123 (pointer-address (make-pointer 123))))
  51
  52   (pass-if "equal?"
  53     (equal? (make-pointer 123) (make-pointer 123)))
  54
  55   (pass-if "equal? modulo finalizer"
  56     (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
  57       (equal? (make-pointer 123)
  58               (make-pointer 123 finalizer))))
  59
  60   (pass-if "not equal?"
  61     (not (equal? (make-pointer 123) (make-pointer 456)))))
  62
  63 \f
  64 (with-test-prefix "pointer<->bytevector"
  65
  66   (pass-if "bijection"
  67     (let ((bv #vu8(0 1 2 3 4 5 6 7)))
  68       (equal? (pointer->bytevector (bytevector->pointer bv)
  69                                    (bytevector-length bv))
  70               bv)))
  71
  72   (pass-if "pointer from bits"
  73     (let* ((bytes (iota (sizeof '*)))
  74            (bv    (u8-list->bytevector bytes)))
  75       (= (pointer-address
  76           (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
  77                                              (sizeof '*))))
  78          (fold-right (lambda (byte address)
  79                        (+ byte (* 256 address)))
  80                      0
  81                      bytes))))
  82
  83   (pass-if "dereference-pointer"
  84     (let* ((bytes (iota (sizeof '*)))
  85            (bv    (u8-list->bytevector bytes)))
  86       (= (pointer-address
  87           (dereference-pointer (bytevector->pointer bv)))
  88          (fold-right (lambda (byte address)
  89                        (+ byte (* 256 address)))
  90                      0
  91                      bytes)))))
  92
  93 \f
  94 (with-test-prefix "pointer<->string"
  95
  96   (pass-if "bijection"
  97     (let ((s "hello, world"))
  98       (string=? s (pointer->string (string->pointer s)))))
  99
 100   (pass-if "bijection [latin1]"
 101     (with-latin1-locale
 102       (let ((s "Szép jó napot!"))
 103         (string=? s (pointer->string (string->pointer s)))))))
 104
 105 \f
 106 (with-test-prefix "procedure->pointer"
 107
 108   (define qsort
 109     ;; Bindings for libc's `qsort' function.
 110     (pointer->procedure void
 111                         (dynamic-func "qsort" (dynamic-link))
 112                         (list '* size_t size_t '*)))
 113
 114   (define (dereference-pointer-to-byte ptr)
 115     (let ((b (pointer->bytevector ptr 1)))
 116       (bytevector-u8-ref b 0)))
 117
 118   (define input
 119     '(7 1 127 3 5 4 77 2 9 0))
 120
 121   (pass-if "qsort"
 122     (if (defined? 'procedure->pointer)
 123         (let* ((called? #f)
 124                (cmp     (lambda (x y)
 125                           (set! called? #t)
 126                           (- (dereference-pointer-to-byte x)
 127                              (dereference-pointer-to-byte y))))
 128                (ptr     (procedure->pointer int cmp (list '* '*)))
 129                (bv      (u8-list->bytevector input)))
 130           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 131                  (procedure->pointer int cmp (list '* '*)))
 132           (and called?
 133                (equal? (bytevector->u8-list bv)
 134                        (sort input <))))
 135         (throw 'unresolved)))
 136
 137   (pass-if-exception "qsort, wrong return type"
 138     exception:wrong-type-arg
 139
 140     (if (defined? 'procedure->pointer)
 141         (let* ((cmp     (lambda (x y) #f)) ; wrong return type
 142                (ptr     (procedure->pointer int cmp (list '* '*)))
 143                (bv      (u8-list->bytevector input)))
 144           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 145                  (procedure->pointer int cmp (list '* '*)))
 146           #f)
 147         (throw 'unresolved)))
 148
 149   (pass-if-exception "qsort, wrong arity"
 150     exception:wrong-num-args
 151
 152     (if (defined? 'procedure->pointer)
 153         (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
 154                (ptr     (procedure->pointer int cmp (list '* '*)))
 155                (bv      (u8-list->bytevector input)))
 156           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 157                  (procedure->pointer int cmp (list '* '*)))
 158           #f)
 159         (throw 'unresolved)))
 160
 161   (pass-if "bijection"
 162     (if (defined? 'procedure->pointer)
 163         (let* ((proc  (lambda (x y z)
 164                         (+ x y z 0.0)))
 165                (ret   double)
 166                (args  (list float int16 double))
 167                (proc* (pointer->procedure ret
 168                                           (procedure->pointer ret proc args)
 169                                           args))
 170                (arg1  (map (cut / <> 2.0) (iota 123)))
 171                (arg2  (iota 123 32000))
 172                (arg3  (map (cut / <> 4.0) (iota 123 100 4))))
 173           (equal? (map proc arg1 arg2 arg3)
 174                   (map proc* arg1 arg2 arg3)))
 175         (throw 'unresolved))))
 176
 177 \f
 178 (with-test-prefix "structs"
 179
 180   (pass-if "parse-c-struct"
 181     (let ((layout (list int64 uint8))
 182           (data   (list -300 43)))
 183       (equal? (parse-c-struct (make-c-struct layout data)
 184                               layout)
 185               data)))
 186
 187   (pass-if "alignment constraints honored"
 188     (let ((layout (list int8 double))
 189           (data   (list -7 3.14)))
 190       (equal? (parse-c-struct (make-c-struct layout data)
 191                               layout)
 192               data)))
 193
 194   (pass-if "int8, pointer"
 195     (let ((layout (list uint8 '*))
 196           (data   (list 222 (make-pointer 7777))))
 197       (equal? (parse-c-struct (make-c-struct layout data)
 198                               layout)
 199               data)))
 200
 201   (pass-if "unsigned-long, int8, size_t"
 202     (let ((layout (list unsigned-long int8 size_t))
 203           (data   (list (expt 2 17) -128 (expt 2 18))))
 204       (equal? (parse-c-struct (make-c-struct layout data)
 205                               layout)
 206               data)))
 207
 208   (pass-if "long, int, pointer"
 209     (let ((layout (list long int '*))
 210           (data   (list (- (expt 2 17)) -222 (make-pointer 777))))
 211       (equal? (parse-c-struct (make-c-struct layout data)
 212                               layout)
 213               data)))
 214
 215   (pass-if "int8, pointer, short, double"
 216     (let ((layout (list int8 '* short double))
 217           (data   (list 77 %null-pointer -42 3.14)))
 218       (equal? (parse-c-struct (make-c-struct layout data)
 219                               layout)
 220               data))))