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