test-suite/tests/foreign.test

   1 ;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011, 2012, 2013 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 (ice-9 format)
  29   #:use-module (test-suite lib))
  30
  31 \f
  32 (with-test-prefix "dynamic-pointer"
  33
  34   (pass-if-exception
  35    "error message"
  36    '(misc-error . "^Symbol not found")
  37    (dynamic-func "does_not_exist___" (dynamic-link))))
  38
  39 \f
  40 (with-test-prefix "null pointer"
  41
  42   (pass-if "pointer?"
  43     (pointer? %null-pointer))
  44
  45   (pass-if "zero"
  46     (= 0 (pointer-address %null-pointer)))
  47
  48   (pass-if "null pointer identity"
  49     (eq? %null-pointer (make-pointer 0)))
  50
  51   (pass-if "null-pointer? %null-pointer"
  52     (null-pointer? %null-pointer))
  53
  54   (pass-if-exception "pointer->bytevector %null-pointer"
  55     exception:null-pointer-error
  56     (pointer->bytevector %null-pointer 7)))
  57
  58 \f
  59 (with-test-prefix "make-pointer"
  60
  61   (pass-if "pointer?"
  62     (pointer? (make-pointer 123)))
  63
  64   (pass-if "address preserved"
  65     (= 123 (pointer-address (make-pointer 123))))
  66
  67   (pass-if "equal?"
  68     (equal? (make-pointer 123) (make-pointer 123)))
  69
  70   (pass-if "equal? modulo finalizer"
  71     (let ((finalizer (false-if-exception
  72                       (dynamic-func "scm_is_pair" (dynamic-link)))))
  73       (if (not finalizer)
  74           (throw 'unresolved)               ;  Windows or a static build
  75           (equal? (make-pointer 123)
  76                   (make-pointer 123 finalizer)))))
  77
  78   (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
  79     (let ((finalizer (false-if-exception
  80                       (dynamic-func "scm_is_pair" (dynamic-link))))
  81           (ptr       (make-pointer 123)))
  82       (if (not finalizer)
  83           (throw 'unresolved)                ; Windows or a static build
  84           (begin
  85             (set-pointer-finalizer! ptr finalizer)
  86             (equal? (make-pointer 123) ptr)))))
  87
  88   (pass-if "not equal?"
  89     (not (equal? (make-pointer 123) (make-pointer 456)))))
  90
  91 \f
  92 (with-test-prefix "pointer<->scm"
  93
  94   (pass-if "immediates"
  95     (equal? (pointer->scm (scm->pointer #\newline))
  96             #\newline))
  97
  98   (pass-if "non-immediates"
  99     (equal? (pointer->scm (scm->pointer "Hello, world!"))
 100             "Hello, world!")))
 101
 102 \f
 103 (define-wrapped-pointer-type foo
 104   foo?
 105   wrap-foo unwrap-foo
 106   (lambda (x p)
 107     (format p "#<foo! ~a>" (pointer-address (unwrap-foo x)))))
 108
 109 (with-test-prefix "define-wrapped-pointer-type"
 110
 111   (pass-if "foo?"
 112     (foo? (wrap-foo %null-pointer)))
 113
 114   (pass-if "unwrap-foo"
 115     (let ((p (make-pointer 123)))
 116       (eq? p (unwrap-foo (wrap-foo p)))))
 117
 118   (pass-if "identity"
 119     (let ((p1 (make-pointer 123))
 120           (p2 (make-pointer 123)))
 121       (eq? (wrap-foo p1)
 122            (wrap-foo p2))))
 123
 124   (pass-if "printer"
 125     (string=? "#<foo! 123>"
 126               (with-output-to-string
 127                 (lambda ()
 128                   (write (wrap-foo (make-pointer 123))))))))
 129
 130 \f
 131 (with-test-prefix "pointer<->bytevector"
 132
 133   (pass-if "bijection"
 134     (let ((bv #vu8(0 1 2 3 4 5 6 7)))
 135       (equal? (pointer->bytevector (bytevector->pointer bv)
 136                                    (bytevector-length bv))
 137               bv)))
 138
 139   (pass-if "pointer from bits"
 140     (let* ((bytes (iota (sizeof '*)))
 141            (bv    (u8-list->bytevector bytes))
 142            (fold  (case (native-endianness)
 143                     ((little) fold-right)
 144                     ((big)    fold)
 145                     (else     (error "unsupported endianness")))))
 146       (= (pointer-address
 147           (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
 148                                              (sizeof '*))))
 149          (fold (lambda (byte address)
 150                  (+ byte (* 256 address)))
 151                0
 152                bytes))))
 153
 154   (pass-if "dereference-pointer"
 155     (let* ((bytes (iota (sizeof '*)))
 156            (bv    (u8-list->bytevector bytes))
 157            (fold  (case (native-endianness)
 158                     ((little) fold-right)
 159                     ((big)    fold)
 160                     (else     (error "unsupported endianness")))))
 161       (= (pointer-address
 162           (dereference-pointer (bytevector->pointer bv)))
 163          (fold (lambda (byte address)
 164                  (+ byte (* 256 address)))
 165                0
 166                bytes)))))
 167
 168 \f
 169 (with-test-prefix "pointer<->string"
 170
 171   (pass-if-exception "%default-port-conversion-strategy is error"
 172     exception:encoding-error
 173     (let ((s "χαοσ"))
 174       (with-fluids ((%default-port-conversion-strategy 'error))
 175         (string->pointer s "ISO-8859-1"))))
 176
 177   (pass-if "%default-port-conversion-strategy is escape"
 178     (let ((s "teĥniko"))
 179       (equal? (with-fluids ((%default-port-conversion-strategy 'escape))
 180                 (pointer->string (string->pointer s "ISO-8859-1")))
 181               (format #f "te\\u~4,'0xniko"
 182                       (char->integer #\ĥ)))))
 183
 184   (pass-if "%default-port-conversion-strategy is substitute"
 185     (let ((s "teĥniko")
 186           (member (negate (negate member))))
 187       (member (with-fluids ((%default-port-conversion-strategy 'substitute))
 188                 (pointer->string (string->pointer s "ISO-8859-1")))
 189               '("te?niko"
 190
 191                 ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
 192                 "te^hniko"))))
 193
 194   (pass-if "bijection"
 195     (let ((s "hello, world"))
 196       (string=? s (pointer->string (string->pointer s)))))
 197
 198   (pass-if "bijection [latin1]"
 199     (with-latin1-locale
 200       (let ((s "Szép jó napot!"))
 201         (string=? s (pointer->string (string->pointer s))))))
 202
 203   (pass-if "bijection, utf-8"
 204     (let ((s "hello, world"))
 205       (string=? s (pointer->string (string->pointer s "utf-8")
 206                                    -1 "utf-8"))))
 207
 208   (pass-if "bijection, utf-8 [latin1]"
 209     (let ((s "Szép jó napot!"))
 210       (string=? s (pointer->string (string->pointer s "utf-8")
 211                                    -1 "utf-8")))))
 212
 213
 214 \f
 215 (with-test-prefix "pointer->procedure"
 216
 217   (pass-if-exception "object instead of pointer"
 218     exception:wrong-type-arg
 219     (let ((p (pointer->procedure '* %null-pointer '(*))))
 220       (p #t))))
 221
 222 \f
 223 (with-test-prefix "procedure->pointer"
 224
 225   (define qsort
 226     ;; Bindings for libc's `qsort' function.
 227     ;; On some platforms, such as MinGW, `qsort' is visible only if
 228     ;; linking with `-export-dynamic'.  Just skip these tests when it's
 229     ;; not visible.
 230     (false-if-exception
 231      (pointer->procedure void
 232                          (dynamic-func "qsort" (dynamic-link))
 233                          (list '* size_t size_t '*))))
 234
 235   (define (dereference-pointer-to-byte ptr)
 236     (let ((b (pointer->bytevector ptr 1)))
 237       (bytevector-u8-ref b 0)))
 238
 239   (define input
 240     '(7 1 127 3 5 4 77 2 9 0))
 241
 242   (pass-if "qsort"
 243     (if (and qsort (defined? 'procedure->pointer))
 244         (let* ((called? #f)
 245                (cmp     (lambda (x y)
 246                           (set! called? #t)
 247                           (- (dereference-pointer-to-byte x)
 248                              (dereference-pointer-to-byte y))))
 249                (ptr     (procedure->pointer int cmp (list '* '*)))
 250                (bv      (u8-list->bytevector input)))
 251           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 252                  (procedure->pointer int cmp (list '* '*)))
 253           (and called?
 254                (equal? (bytevector->u8-list bv)
 255                        (sort input <))))
 256         (throw 'unresolved)))
 257
 258   (pass-if-exception "qsort, wrong return type"
 259     exception:wrong-type-arg
 260
 261     (if (and qsort (defined? 'procedure->pointer))
 262         (let* ((cmp     (lambda (x y) #f)) ; wrong return type
 263                (ptr     (procedure->pointer int cmp (list '* '*)))
 264                (bv      (u8-list->bytevector input)))
 265           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 266                  (procedure->pointer int cmp (list '* '*)))
 267           #f)
 268         (throw 'unresolved)))
 269
 270   (pass-if-exception "qsort, wrong arity"
 271     exception:wrong-num-args
 272
 273     (if (and qsort (defined? 'procedure->pointer))
 274         (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
 275                (ptr     (procedure->pointer int cmp (list '* '*)))
 276                (bv      (u8-list->bytevector input)))
 277           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 278                  (procedure->pointer int cmp (list '* '*)))
 279           #f)
 280         (throw 'unresolved)))
 281
 282   (pass-if "bijection"
 283     (if (defined? 'procedure->pointer)
 284         (let* ((proc  (lambda (x y z)
 285                         (+ x y z 0.0)))
 286                (ret   double)
 287                (args  (list float int16 double))
 288                (proc* (pointer->procedure ret
 289                                           (procedure->pointer ret proc args)
 290                                           args))
 291                (arg1  (map (cut / <> 2.0) (iota 123)))
 292                (arg2  (iota 123 32000))
 293                (arg3  (map (cut / <> 4.0) (iota 123 100 4))))
 294           (equal? (map proc arg1 arg2 arg3)
 295                   (map proc* arg1 arg2 arg3)))
 296         (throw 'unresolved)))
 297
 298   (pass-if "procedures returning a pointer"
 299     (if (defined? 'procedure->pointer)
 300         (let* ((called? #f)
 301                (proc    (lambda (i) (set! called? #t) (make-pointer i)))
 302                (pointer (procedure->pointer '* proc (list int)))
 303                (proc*   (pointer->procedure '* pointer (list int)))
 304                (result  (proc* 777)))
 305           (and called? (equal? result (make-pointer 777))))
 306         (throw 'unresolved)))
 307
 308   (pass-if "procedures returning void"
 309     (if (defined? 'procedure->pointer)
 310         (let* ((called? #f)
 311                (proc    (lambda () (set! called? #t)))
 312                (pointer (procedure->pointer void proc '()))
 313                (proc*   (pointer->procedure void pointer '())))
 314           (proc*)
 315           called?)
 316         (throw 'unresolved)))
 317
 318   (pass-if "procedure is retained"
 319     ;; The lambda passed to `procedure->pointer' must remain live.
 320     (if (defined? 'procedure->pointer)
 321         (let* ((ptr   (procedure->pointer int
 322                                           (lambda (x) (+ x 7))
 323                                           (list int)))
 324                (procs (unfold (cut >= <> 10000)
 325                               (lambda (i)
 326                                 (pointer->procedure int ptr (list int)))
 327                               1+
 328                               0)))
 329           (gc) (gc) (gc)
 330           (every (cut = <> 9)
 331                  (map (lambda (f) (f 2)) procs)))
 332         (throw 'unresolved))))
 333
 334 \f
 335 (with-test-prefix "structs"
 336
 337   (pass-if "sizeof { int8, double }"
 338     (= (sizeof (list int8 double))
 339        (+ (alignof double) (sizeof double))))
 340
 341   (pass-if "sizeof { double, int8 }"
 342     (= (sizeof (list double int8))
 343        (+ (alignof double) (sizeof double))))
 344
 345   (pass-if "sizeof { short, int, long, pointer }"
 346     (let ((layout (list short int long '*)))
 347       (>= (sizeof layout)
 348           (reduce + 0.0 (map sizeof layout)))))
 349
 350   (pass-if "alignof { int8, double, int8 }"
 351     ;; alignment of the most strictly aligned component
 352     (let ((layout (list int8 double int8)))
 353       (= (alignof layout) (alignof double))))
 354
 355   (pass-if "parse-c-struct"
 356     (let ((layout (list int64 uint8))
 357           (data   (list -300 43)))
 358       (equal? (parse-c-struct (make-c-struct layout data)
 359                               layout)
 360               data)))
 361
 362   (pass-if "alignment constraints honored"
 363     (let ((layout (list int8 double))
 364           (data   (list -7 3.14)))
 365       (equal? (parse-c-struct (make-c-struct layout data)
 366                               layout)
 367               data)))
 368
 369   (pass-if "int8, pointer"
 370     (let ((layout (list uint8 '*))
 371           (data   (list 222 (make-pointer 7777))))
 372       (equal? (parse-c-struct (make-c-struct layout data)
 373                               layout)
 374               data)))
 375
 376   (pass-if "unsigned-long, int8, size_t"
 377     (let ((layout (list unsigned-long int8 size_t))
 378           (data   (list (expt 2 17) -128 (expt 2 18))))
 379       (equal? (parse-c-struct (make-c-struct layout data)
 380                               layout)
 381               data)))
 382
 383   (pass-if "long, int, pointer"
 384     (let ((layout (list long int '*))
 385           (data   (list (- (expt 2 17)) -222 (make-pointer 777))))
 386       (equal? (parse-c-struct (make-c-struct layout data)
 387                               layout)
 388               data)))
 389
 390   (pass-if "int8, pointer, short, double"
 391     (let ((layout (list int8 '* short double))
 392           (data   (list 77 %null-pointer -42 3.14)))
 393       (equal? (parse-c-struct (make-c-struct layout data)
 394                               layout)
 395               data)))
 396
 397   (pass-if "int8, { int8, double, int8 }, int16"
 398     (let ((layout (list int8 (list int8 double int8) int16))
 399           (data   (list 77 (list 42 4.2 55) 88)))
 400       (equal? (parse-c-struct (make-c-struct layout data)
 401                               layout)
 402               data))))