test-suite/standalone/test-ffi

   1 #!/bin/sh
   2 exec guile -q -s "$0" "$@"
   3 !#
   4 ;;; test-ffi --- Foreign function interface.         -*- Scheme -*-
   5 ;;;
   6 ;;; Copyright (C) 2010 Free Software Foundation, Inc.
   7 ;;;
   8 ;;; This library is free software; you can redistribute it and/or
   9 ;;; modify it under the terms of the GNU Lesser General Public
  10 ;;; License as published by the Free Software Foundation; either
  11 ;;; version 3 of the License, or (at your option) any later version.
  12 ;;;
  13 ;;; This library is distributed in the hope that it will be useful,
  14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 ;;; Lesser General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU Lesser General Public
  19 ;;; License along with this library; if not, write to the Free Software
  20 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  21
  22 (use-modules (system foreign)
  23              (rnrs bytevectors)
  24              (srfi srfi-1)
  25              (srfi srfi-26))
  26
  27 (define lib
  28   (dynamic-link (string-append (getenv "builddir") "/libtest-ffi")))
  29
  30 (define failed? #f)
  31
  32 (define-syntax test
  33   (syntax-rules ()
  34     ((_ exp res)
  35      (let ((expected res)
  36            (actual exp))
  37        (if (not (equal? actual expected))
  38            (begin
  39              (set! failed? #t)
  40              (format (current-error-port)
  41                      "bad return from expression `~a': expected ~A; got ~A~%"
  42                      'exp expected actual)))))))
  43
  44 ;;;
  45 ;;; No args
  46 ;;;
  47 (define f-v-
  48   (pointer->procedure void (dynamic-func "test_ffi_v_" lib) '()))
  49 (test (f-v-) *unspecified*)
  50
  51 (define f-s8-
  52   (pointer->procedure int8 (dynamic-func "test_ffi_s8_" lib) '()))
  53 (test (f-s8-) -100)
  54
  55 (define f-u8-
  56   (pointer->procedure uint8 (dynamic-func "test_ffi_u8_" lib) '()))
  57 (test (f-u8-) 200)
  58
  59 (define f-s16-
  60   (pointer->procedure int16 (dynamic-func "test_ffi_s16_" lib) '()))
  61 (test (f-s16-) -20000)
  62
  63 (define f-u16-
  64   (pointer->procedure uint16 (dynamic-func "test_ffi_u16_" lib) '()))
  65 (test (f-u16-) 40000)
  66
  67 (define f-s32-
  68   (pointer->procedure int32 (dynamic-func "test_ffi_s32_" lib) '()))
  69 (test (f-s32-) -2000000000)
  70
  71 (define f-u32-
  72   (pointer->procedure uint32 (dynamic-func "test_ffi_u32_" lib) '()))
  73 (test (f-u32-) 4000000000)
  74
  75 (define f-s64-
  76   (pointer->procedure int64 (dynamic-func "test_ffi_s64_" lib) '()))
  77 (test (f-s64-) -2000000000)
  78
  79 (define f-u64-
  80   (pointer->procedure uint64 (dynamic-func "test_ffi_u64_" lib) '()))
  81 (test (f-u64-) 4000000000)
  82
  83 ;;;
  84 ;;; One u8 arg
  85 ;;;
  86 (define f-v-u8
  87   (pointer->procedure void (dynamic-func "test_ffi_v_u8" lib) (list uint8)))
  88 (test (f-v-u8 10) *unspecified*)
  89
  90 (define f-s8-u8
  91   (pointer->procedure int8 (dynamic-func "test_ffi_s8_u8" lib) (list uint8)))
  92 (test (f-s8-u8 10) -90)
  93
  94 (define f-u8-u8
  95   (pointer->procedure uint8 (dynamic-func "test_ffi_u8_u8" lib) (list uint8)))
  96 (test (f-u8-u8 10) 210)
  97
  98 (define f-s16-u8
  99   (pointer->procedure int16 (dynamic-func "test_ffi_s16_u8" lib) (list uint8)))
 100 (test (f-s16-u8 10) -19990)
 101
 102 (define f-u16-u8
 103   (pointer->procedure uint16 (dynamic-func "test_ffi_u16_u8" lib) (list uint8)))
 104 (test (f-u16-u8 10) 40010)
 105
 106 (define f-s32-u8
 107   (pointer->procedure int32 (dynamic-func "test_ffi_s32_u8" lib) (list uint8)))
 108 (test (f-s32-u8 10) -1999999990)
 109
 110 (define f-u32-u8
 111   (pointer->procedure uint32 (dynamic-func "test_ffi_u32_u8" lib) (list uint8)))
 112 (test (f-u32-u8 10) 4000000010)
 113
 114 (define f-s64-u8
 115   (pointer->procedure int64 (dynamic-func "test_ffi_s64_u8" lib) (list uint8)))
 116 (test (f-s64-u8 10) -1999999990)
 117
 118 (define f-u64-u8
 119   (pointer->procedure uint64 (dynamic-func "test_ffi_u64_u8" lib) (list uint8)))
 120 (test (f-u64-u8 10) 4000000010)
 121
 122
 123 ;;;
 124 ;;; One s64 arg
 125 ;;;
 126 (define f-v-s64
 127   (pointer->procedure void (dynamic-func "test_ffi_v_s64" lib) (list int64)))
 128 (test (f-v-s64 10) *unspecified*)
 129
 130 (define f-s8-s64
 131   (pointer->procedure int8 (dynamic-func "test_ffi_s8_s64" lib) (list int64)))
 132 (test (f-s8-s64 10) -90)
 133
 134 (define f-u8-s64
 135   (pointer->procedure uint8 (dynamic-func "test_ffi_u8_s64" lib) (list int64)))
 136 (test (f-u8-s64 10) 210)
 137
 138 (define f-s16-s64
 139   (pointer->procedure int16 (dynamic-func "test_ffi_s16_s64" lib) (list int64)))
 140 (test (f-s16-s64 10) -19990)
 141
 142 (define f-u16-s64
 143   (pointer->procedure uint16 (dynamic-func "test_ffi_u16_s64" lib) (list int64)))
 144 (test (f-u16-s64 10) 40010)
 145
 146 (define f-s32-s64
 147   (pointer->procedure int32 (dynamic-func "test_ffi_s32_s64" lib) (list int64)))
 148 (test (f-s32-s64 10) -1999999990)
 149
 150 (define f-u32-s64
 151   (pointer->procedure uint32 (dynamic-func "test_ffi_u32_s64" lib) (list int64)))
 152 (test (f-u32-s64 10) 4000000010)
 153
 154 (define f-s64-s64
 155   (pointer->procedure int64 (dynamic-func "test_ffi_s64_s64" lib) (list int64)))
 156 (test (f-s64-s64 10) -1999999990)
 157
 158 (define f-u64-s64
 159   (pointer->procedure uint64 (dynamic-func "test_ffi_u64_s64" lib) (list int64)))
 160 (test (f-u64-s64 10) 4000000010)
 161
 162
 163 ;;
 164 ;; Multiple int args of differing types
 165 ;;
 166 (define f-sum
 167   (pointer->procedure int64 (dynamic-func "test_ffi_sum" lib)
 168                       (list int8 int16 int32 int64)))
 169 (test (f-sum -1 2000 -30000 40000000000)
 170       (+ -1 2000 -30000 40000000000))
 171
 172 ;;
 173 ;; More than ten arguments
 174 ;;
 175 (define f-sum-many
 176   (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib)
 177                       (list uint8 uint16 uint32 uint64
 178                             int8 int16 int32 int64
 179                             int8 int16 int32 int64)))
 180 (test (f-sum-many 255 65535 4294967295 1844674407370955161
 181                   -1 2000 -30000 40000000000
 182                   5 -6000 70000 -80000000000)
 183       (+ 255 65535 4294967295 1844674407370955161
 184                   -1 2000 -30000 40000000000
 185                   5 -6000 70000 -80000000000))
 186
 187 ;;
 188 ;; Structs
 189 ;;
 190 (define f-sum-struct
 191   (pointer->procedure int64 (dynamic-func "test_ffi_sum_struct" lib)
 192                       (list (list int8 int16 int32 int64))))
 193 (test (f-sum-struct (make-c-struct (list int8 int16 int32 int64)
 194                                    (list -1 2000 -30000 40000000000)))
 195       (+ -1 2000 -30000 40000000000))
 196 ;;
 197 ;; Structs
 198 ;;
 199 (define f-memcpy
 200   (pointer->procedure '* (dynamic-func "test_ffi_memcpy" lib)
 201                       (list '* '* int32)))
 202 (let* ((src* '(0 1 2 3 4 5 6 7))
 203        (src  (bytevector->pointer (u8-list->bytevector src*)))
 204        (dest (bytevector->pointer (make-bytevector 16 0)))
 205        (res  (f-memcpy dest src (length src*))))
 206   (or (= (pointer-address dest) (pointer-address res))
 207       (error "memcpy res not equal to dest"))
 208   (or (equal? (bytevector->u8-list (pointer->bytevector dest 16))
 209               '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0))
 210       (error "unexpected dest")))
 211
 212 ;;
 213 ;; Function pointers
 214 ;;
 215
 216 (define f-callback-1
 217   (pointer->procedure int (dynamic-func "test_ffi_callback_1" lib)
 218                       (list '* int)))
 219
 220 (if (defined? 'procedure->pointer)
 221     (let* ((calls 0)
 222            (ptr   (procedure->pointer int
 223                                       (lambda (x)
 224                                         (set! calls (+ 1 calls))
 225                                         (* x 3))
 226                                       (list int)))
 227            (input (iota 123)))
 228       (define (expected-result x)
 229         (+ 7 (* x 3)))
 230
 231       (let ((result (map (cut f-callback-1 ptr <>) input)))
 232         (and (or (= calls (length input))
 233                  (error "incorrect number of callback calls" calls))
 234              (or (equal? (map expected-result input) result)
 235                  (error "incorrect result" result))))))
 236
 237 (define f-callback-2
 238   (pointer->procedure double (dynamic-func "test_ffi_callback_2" lib)
 239                       (list '* float int double)))
 240
 241 (if (defined? 'procedure->pointer)
 242     (let* ((proc  (lambda (x y z)
 243                     (* (+ x (exact->inexact y)) z)))
 244            (ptr   (procedure->pointer double proc
 245                                       (list float int double)))
 246            (arg1 (map (cut * <> 1.25) (iota 123 500)))
 247            (arg2 (iota 123))
 248            (arg3 (map (cut / <> 2.0) (iota 123 0 -10))))
 249       (define result
 250         (map (cut f-callback-2 ptr <> <> <>)
 251              arg1 arg2 arg3))
 252
 253       (or (equal? result (map proc arg1 arg2 arg3))
 254           (error "incorrect result" result))))
 255
 256 \f
 257 ;;;
 258 ;;; Global symbols.
 259 ;;;
 260
 261 (use-modules ((rnrs bytevectors) #:select (utf8->string)))
 262
 263 (if (defined? 'setlocale)
 264     (setlocale LC_ALL "C"))
 265
 266 (define global (dynamic-link))
 267
 268 (define strerror
 269   (pointer->procedure '* (dynamic-func "strerror" global)
 270                       (list int)))
 271
 272 (define strlen
 273   (pointer->procedure size_t (dynamic-func "strlen" global)
 274                       (list '*)))
 275
 276 (let* ((ptr (strerror ENOENT))
 277        (len (strlen ptr))
 278        (bv  (pointer->bytevector ptr len 0 'u8))
 279        (str (utf8->string bv)))
 280   (test #t (not (not (string-contains str "file")))))
 281
 282 (exit (not failed?))
 283
 284 ;; Local Variables:
 285 ;; mode: scheme
 286 ;; End: