test-suite/tests/foreign.test

   1 ;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011 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 "dynamic-pointer"
  32
  33   (pass-if-exception
  34    "error message"
  35    '(misc-error . "^Symbol not found")
  36    (dynamic-func "does_not_exist___" (dynamic-link))))
  37
  38 \f
  39 (with-test-prefix "null pointer"
  40
  41   (pass-if "pointer?"
  42     (pointer? %null-pointer))
  43
  44   (pass-if "zero"
  45     (= 0 (pointer-address %null-pointer)))
  46
  47   (pass-if "null pointer identity"
  48     (eq? %null-pointer (make-pointer 0)))
  49
  50   (pass-if "null-pointer? %null-pointer"
  51     (null-pointer? %null-pointer))
  52
  53   (pass-if-exception "pointer->bytevector %null-pointer"
  54     exception:null-pointer-error
  55     (pointer->bytevector %null-pointer 7)))
  56
  57 \f
  58 (with-test-prefix "make-pointer"
  59
  60   (pass-if "pointer?"
  61     (pointer? (make-pointer 123)))
  62
  63   (pass-if "address preserved"
  64     (= 123 (pointer-address (make-pointer 123))))
  65
  66   (pass-if "equal?"
  67     (equal? (make-pointer 123) (make-pointer 123)))
  68
  69   (pass-if "equal? modulo finalizer"
  70     (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
  71       (equal? (make-pointer 123)
  72               (make-pointer 123 finalizer))))
  73
  74   (pass-if "not equal?"
  75     (not (equal? (make-pointer 123) (make-pointer 456)))))
  76
  77 \f
  78 (with-test-prefix "pointer<->scm"
  79
  80   (pass-if "immediates"
  81     (equal? (pointer->scm (scm->pointer #\newline))
  82             #\newline))
  83
  84   (pass-if "non-immediates"
  85     (equal? (pointer->scm (scm->pointer "Hello, world!"))
  86             "Hello, world!")))
  87
  88 \f
  89 (define-wrapped-pointer-type foo
  90   foo?
  91   wrap-foo unwrap-foo
  92   (lambda (x p)
  93     (format p "#<foo! ~a>" (pointer-address (unwrap-foo x)))))
  94
  95 (with-test-prefix "define-wrapped-pointer-type"
  96
  97   (pass-if "foo?"
  98     (foo? (wrap-foo %null-pointer)))
  99
 100   (pass-if "unwrap-foo"
 101     (let ((p (make-pointer 123)))
 102       (eq? p (unwrap-foo (wrap-foo p)))))
 103
 104   (pass-if "identity"
 105     (let ((p1 (make-pointer 123))
 106           (p2 (make-pointer 123)))
 107       (eq? (wrap-foo p1)
 108            (wrap-foo p2))))
 109
 110   (pass-if "printer"
 111     (string=? "#<foo! 123>"
 112               (with-output-to-string
 113                 (lambda ()
 114                   (write (wrap-foo (make-pointer 123))))))))
 115
 116 \f
 117 (with-test-prefix "pointer<->bytevector"
 118
 119   (pass-if "bijection"
 120     (let ((bv #vu8(0 1 2 3 4 5 6 7)))
 121       (equal? (pointer->bytevector (bytevector->pointer bv)
 122                                    (bytevector-length bv))
 123               bv)))
 124
 125   (pass-if "pointer from bits"
 126     (let* ((bytes (iota (sizeof '*)))
 127            (bv    (u8-list->bytevector bytes))
 128            (fold  (case (native-endianness)
 129                     ((little) fold-right)
 130                     ((big)    fold)
 131                     (else     (error "unsupported endianness")))))
 132       (= (pointer-address
 133           (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
 134                                              (sizeof '*))))
 135          (fold (lambda (byte address)
 136                  (+ byte (* 256 address)))
 137                0
 138                bytes))))
 139
 140   (pass-if "dereference-pointer"
 141     (let* ((bytes (iota (sizeof '*)))
 142            (bv    (u8-list->bytevector bytes))
 143            (fold  (case (native-endianness)
 144                     ((little) fold-right)
 145                     ((big)    fold)
 146                     (else     (error "unsupported endianness")))))
 147       (= (pointer-address
 148           (dereference-pointer (bytevector->pointer bv)))
 149          (fold (lambda (byte address)
 150                  (+ byte (* 256 address)))
 151                0
 152                bytes)))))
 153
 154 \f
 155 (with-test-prefix "pointer<->string"
 156
 157   (pass-if "bijection"
 158     (let ((s "hello, world"))
 159       (string=? s (pointer->string (string->pointer s)))))
 160
 161   (pass-if "bijection [latin1]"
 162     (with-latin1-locale
 163       (let ((s "Szép jó napot!"))
 164         (string=? s (pointer->string (string->pointer s))))))
 165
 166   (pass-if "bijection, utf-8"
 167     (let ((s "hello, world"))
 168       (string=? s (pointer->string (string->pointer s "utf-8")
 169                                    -1 "utf-8"))))
 170
 171   (pass-if "bijection, utf-8 [latin1]"
 172     (let ((s "Szép jó napot!"))
 173       (string=? s (pointer->string (string->pointer s "utf-8")
 174                                    -1 "utf-8")))))
 175
 176
 177 \f
 178 (with-test-prefix "pointer->procedure"
 179
 180   (pass-if-exception "object instead of pointer"
 181     exception:wrong-type-arg
 182     (let ((p (pointer->procedure '* %null-pointer '(*))))
 183       (p #t))))
 184
 185 \f
 186 (with-test-prefix "procedure->pointer"
 187
 188   (define qsort
 189     ;; Bindings for libc's `qsort' function.
 190     (pointer->procedure void
 191                         (dynamic-func "qsort" (dynamic-link))
 192                         (list '* size_t size_t '*)))
 193
 194   (define (dereference-pointer-to-byte ptr)
 195     (let ((b (pointer->bytevector ptr 1)))
 196       (bytevector-u8-ref b 0)))
 197
 198   (define input
 199     '(7 1 127 3 5 4 77 2 9 0))
 200
 201   (pass-if "qsort"
 202     (if (defined? 'procedure->pointer)
 203         (let* ((called? #f)
 204                (cmp     (lambda (x y)
 205                           (set! called? #t)
 206                           (- (dereference-pointer-to-byte x)
 207                              (dereference-pointer-to-byte y))))
 208                (ptr     (procedure->pointer int cmp (list '* '*)))
 209                (bv      (u8-list->bytevector input)))
 210           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 211                  (procedure->pointer int cmp (list '* '*)))
 212           (and called?
 213                (equal? (bytevector->u8-list bv)
 214                        (sort input <))))
 215         (throw 'unresolved)))
 216
 217   (pass-if-exception "qsort, wrong return type"
 218     exception:wrong-type-arg
 219
 220     (if (defined? 'procedure->pointer)
 221         (let* ((cmp     (lambda (x y) #f)) ; wrong return type
 222                (ptr     (procedure->pointer int cmp (list '* '*)))
 223                (bv      (u8-list->bytevector input)))
 224           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 225                  (procedure->pointer int cmp (list '* '*)))
 226           #f)
 227         (throw 'unresolved)))
 228
 229   (pass-if-exception "qsort, wrong arity"
 230     exception:wrong-num-args
 231
 232     (if (defined? 'procedure->pointer)
 233         (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
 234                (ptr     (procedure->pointer int cmp (list '* '*)))
 235                (bv      (u8-list->bytevector input)))
 236           (qsort (bytevector->pointer bv) (bytevector-length bv) 1
 237                  (procedure->pointer int cmp (list '* '*)))
 238           #f)
 239         (throw 'unresolved)))
 240
 241   (pass-if "bijection"
 242     (if (defined? 'procedure->pointer)
 243         (let* ((proc  (lambda (x y z)
 244                         (+ x y z 0.0)))
 245                (ret   double)
 246                (args  (list float int16 double))
 247                (proc* (pointer->procedure ret
 248                                           (procedure->pointer ret proc args)
 249                                           args))
 250                (arg1  (map (cut / <> 2.0) (iota 123)))
 251                (arg2  (iota 123 32000))
 252                (arg3  (map (cut / <> 4.0) (iota 123 100 4))))
 253           (equal? (map proc arg1 arg2 arg3)
 254                   (map proc* arg1 arg2 arg3)))
 255         (throw 'unresolved)))
 256
 257   (pass-if "procedures returning void"
 258     (if (defined? 'procedure->pointer)
 259         (let* ((called? #f)
 260                (proc    (lambda () (set! called? #t)))
 261                (pointer (procedure->pointer void proc '()))
 262                (proc*   (pointer->procedure void pointer '())))
 263           (proc*)
 264           called?)
 265         (throw 'unresolved))))
 266
 267 \f
 268 (with-test-prefix "structs"
 269
 270   (pass-if "sizeof { int8, double }"
 271     (= (sizeof (list int8 double))
 272        (+ (alignof double) (sizeof double))))
 273
 274   (pass-if "sizeof { short, int, long, pointer }"
 275     (let ((layout (list short int long '*)))
 276       (>= (sizeof layout)
 277           (reduce + 0.0 (map sizeof layout)))))
 278
 279   (pass-if "alignof { int8, double, int8 }"
 280     ;; alignment of the most strictly aligned component
 281     (let ((layout (list int8 double int8)))
 282       (= (alignof layout) (alignof double))))
 283
 284   (pass-if "parse-c-struct"
 285     (let ((layout (list int64 uint8))
 286           (data   (list -300 43)))
 287       (equal? (parse-c-struct (make-c-struct layout data)
 288                               layout)
 289               data)))
 290
 291   (pass-if "alignment constraints honored"
 292     (let ((layout (list int8 double))
 293           (data   (list -7 3.14)))
 294       (equal? (parse-c-struct (make-c-struct layout data)
 295                               layout)
 296               data)))
 297
 298   (pass-if "int8, pointer"
 299     (let ((layout (list uint8 '*))
 300           (data   (list 222 (make-pointer 7777))))
 301       (equal? (parse-c-struct (make-c-struct layout data)
 302                               layout)
 303               data)))
 304
 305   (pass-if "unsigned-long, int8, size_t"
 306     (let ((layout (list unsigned-long int8 size_t))
 307           (data   (list (expt 2 17) -128 (expt 2 18))))
 308       (equal? (parse-c-struct (make-c-struct layout data)
 309                               layout)
 310               data)))
 311
 312   (pass-if "long, int, pointer"
 313     (let ((layout (list long int '*))
 314           (data   (list (- (expt 2 17)) -222 (make-pointer 777))))
 315       (equal? (parse-c-struct (make-c-struct layout data)
 316                               layout)
 317               data)))
 318
 319   (pass-if "int8, pointer, short, double"
 320     (let ((layout (list int8 '* short double))
 321           (data   (list 77 %null-pointer -42 3.14)))
 322       (equal? (parse-c-struct (make-c-struct layout data)
 323                               layout)
 324               data)))
 325
 326   (pass-if "int8, { int8, double, int8 }, int16"
 327     (let ((layout (list int8 (list int8 double int8) int16))
 328           (data   (list 77 (list 42 4.2 55) 88)))
 329       (equal? (parse-c-struct (make-c-struct layout data)
 330                               layout)
 331               data))))