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 \f
  53 (with-test-prefix "pointer<->bytevector"
  54
  55   (pass-if "bijection"
  56     (let ((bv #vu8(0 1 2 3 4 5 6 7)))
  57       (equal? (pointer->bytevector (bytevector->pointer bv)
  58                                    (bytevector-length bv))
  59               bv)))
  60
  61   (pass-if "pointer from bits"
  62     (let* ((bytes (iota (sizeof '*)))
  63            (bv    (u8-list->bytevector bytes)))
  64       (= (pointer-address
  65           (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
  66                                              (sizeof '*))))
  67          (fold-right (lambda (byte address)
  68                        (+ byte (* 256 address)))
  69                      0
  70                      bytes))))
  71
  72   (pass-if "dereference-pointer"
  73     (let* ((bytes (iota (sizeof '*)))
  74            (bv    (u8-list->bytevector bytes)))
  75       (= (pointer-address
  76           (dereference-pointer (bytevector->pointer bv)))
  77          (fold-right (lambda (byte address)
  78                        (+ byte (* 256 address)))
  79                      0
  80                      bytes)))))
  81
  82 \f
  83 (with-test-prefix "pointer<->string"
  84
  85   (pass-if "bijection"
  86     (let ((s "hello, world"))
  87       (string=? s (pointer->string (string->pointer s)))))
  88
  89   (pass-if "bijection [latin1]"
  90     (with-latin1-locale
  91       (let ((s "Szép jó napot!"))
  92         (string=? s (pointer->string (string->pointer s)))))))
  93
  94 \f
  95 (with-test-prefix "procedure->pointer"
  96
  97   (define qsort
  98     ;; Bindings for libc's `qsort' function.
  99     (pointer->procedure void
 100                         (dynamic-func "qsort" (dynamic-link))
 101                         (list '* size_t size_t '*)))
 102
 103   (define (dereference-pointer-to-byte ptr)
 104     (let ((b (pointer->bytevector ptr 1)))
 105       (bytevector-u8-ref b 0)))
 106
 107   (define input
 108     '(7 1 127 3 5 4 77 2 9 0))
 109
 110   (pass-if "qsort"
 111     (if (defined? 'procedure->pointer)
 112         (let* ((called? #f)
 113                (cmp     (lambda (x y)
 114                           (set! called? #t)
 115                           (- (dereference-pointer-to-byte x)
 116                              (dereference-pointer-to-byte y))))
 117                (ptr     (procedure->pointer int cmp (list '* '*)))
 118                (bv      (u8-list->bytevector input)))
 119           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 120                  (procedure->pointer int cmp (list '* '*)))
 121           (and called?
 122                (equal? (bytevector->u8-list bv)
 123                        (sort input <))))
 124         (throw 'unresolved)))
 125
 126   (pass-if-exception "qsort, wrong return type"
 127     exception:wrong-type-arg
 128
 129     (if (defined? 'procedure->pointer)
 130         (let* ((cmp     (lambda (x y) #f)) ; wrong return type
 131                (ptr     (procedure->pointer int cmp (list '* '*)))
 132                (bv      (u8-list->bytevector input)))
 133           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 134                  (procedure->pointer int cmp (list '* '*)))
 135           #f)
 136         (throw 'unresolved)))
 137
 138   (pass-if-exception "qsort, wrong arity"
 139     exception:wrong-num-args
 140
 141     (if (defined? 'procedure->pointer)
 142         (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
 143                (ptr     (procedure->pointer int cmp (list '* '*)))
 144                (bv      (u8-list->bytevector input)))
 145           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 146                  (procedure->pointer int cmp (list '* '*)))
 147           #f)
 148         (throw 'unresolved)))
 149
 150   (pass-if "bijection"
 151     (if (defined? 'procedure->pointer)
 152         (let* ((proc  (lambda (x y z)
 153                         (+ x y z 0.0)))
 154                (ret   double)
 155                (args  (list float int16 double))
 156                (proc* (pointer->procedure ret
 157                                           (procedure->pointer ret proc args)
 158                                           args))
 159                (arg1  (map (cut / <> 2.0) (iota 123)))
 160                (arg2  (iota 123 32000))
 161                (arg3  (map (cut / <> 4.0) (iota 123 100 4))))
 162           (equal? (map proc arg1 arg2 arg3)
 163                   (map proc* arg1 arg2 arg3)))
 164         (throw 'unresolved))))
 165
 166 \f
 167 (with-test-prefix "structs"
 168
 169   (pass-if "parse-c-struct"
 170     (let ((layout (list int64 uint8))
 171           (data   (list -300 43)))
 172       (equal? (parse-c-struct (make-c-struct layout data)
 173                               layout)
 174               data))))