summaryrefslogtreecommitdiff
path: root/test-suite/tests/foreign.test
blob: 59ea6b9079f04db54179e3a5cd4debdbb32e4251 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; 	Copyright (C) 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;
;;; See also ../standalone/test-ffi for FFI tests.
;;;

(define-module (test-foreign)
  #:use-module (system foreign)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (test-suite lib))


(with-test-prefix "null pointer"

  (pass-if "zero"
    (= 0 (pointer-address %null-pointer)))

  (pass-if "null pointer identity"
    (eq? %null-pointer (make-pointer 0)))

  (pass-if "null-pointer? %null-pointer"
    (null-pointer? %null-pointer))

  (pass-if-exception "pointer->bytevector %null-pointer"
    exception:null-pointer-error
    (pointer->bytevector %null-pointer 7)))


(with-test-prefix "make-pointer"

  (pass-if "address preserved"
    (= 123 (pointer-address (make-pointer 123))))

  (pass-if "equal?"
    (equal? (make-pointer 123) (make-pointer 123)))

  (pass-if "equal? modulo finalizer"
    (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
      (equal? (make-pointer 123)
              (make-pointer 123 finalizer))))

  (pass-if "not equal?"
    (not (equal? (make-pointer 123) (make-pointer 456)))))


(with-test-prefix "pointer<->bytevector"

  (pass-if "bijection"
    (let ((bv #vu8(0 1 2 3 4 5 6 7)))
      (equal? (pointer->bytevector (bytevector->pointer bv)
                                   (bytevector-length bv))
              bv)))

  (pass-if "pointer from bits"
    (let* ((bytes (iota (sizeof '*)))
           (bv    (u8-list->bytevector bytes)))
      (= (pointer-address
          (make-pointer (bytevector-uint-ref bv 0 (native-endianness)
                                             (sizeof '*))))
         (fold-right (lambda (byte address)
                       (+ byte (* 256 address)))
                     0
                     bytes))))

  (pass-if "dereference-pointer"
    (let* ((bytes (iota (sizeof '*)))
           (bv    (u8-list->bytevector bytes)))
      (= (pointer-address
          (dereference-pointer (bytevector->pointer bv)))
         (fold-right (lambda (byte address)
                       (+ byte (* 256 address)))
                     0
                     bytes)))))


(with-test-prefix "pointer<->string"

  (pass-if "bijection"
    (let ((s "hello, world"))
      (string=? s (pointer->string (string->pointer s)))))

  (pass-if "bijection [latin1]"
    (with-latin1-locale
      (let ((s "Szép jó napot!"))
        (string=? s (pointer->string (string->pointer s)))))))


(with-test-prefix "procedure->pointer"

  (define qsort
    ;; Bindings for libc's `qsort' function.
    (pointer->procedure void
                        (dynamic-func "qsort" (dynamic-link))
                        (list '* size_t size_t '*)))

  (define (dereference-pointer-to-byte ptr)
    (let ((b (pointer->bytevector ptr 1)))
      (bytevector-u8-ref b 0)))

  (define input
    '(7 1 127 3 5 4 77 2 9 0))

  (pass-if "qsort"
    (if (defined? 'procedure->pointer)
        (let* ((called? #f)
               (cmp     (lambda (x y)
                          (set! called? #t)
                          (- (dereference-pointer-to-byte x)
                             (dereference-pointer-to-byte y))))
               (ptr     (procedure->pointer int cmp (list '* '*)))
               (bv      (u8-list->bytevector input)))
          (qsort (bytevector->pointer bv) (bytevector-length bv) 1
                 (procedure->pointer int cmp (list '* '*)))
          (and called?
               (equal? (bytevector->u8-list bv)
                       (sort input <))))
        (throw 'unresolved)))

  (pass-if-exception "qsort, wrong return type"
    exception:wrong-type-arg

    (if (defined? 'procedure->pointer)
        (let* ((cmp     (lambda (x y) #f)) ; wrong return type
               (ptr     (procedure->pointer int cmp (list '* '*)))
               (bv      (u8-list->bytevector input)))
          (qsort (bytevector->pointer bv) (bytevector-length bv) 1
                 (procedure->pointer int cmp (list '* '*)))
          #f)
        (throw 'unresolved)))

  (pass-if-exception "qsort, wrong arity"
    exception:wrong-num-args

    (if (defined? 'procedure->pointer)
        (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
               (ptr     (procedure->pointer int cmp (list '* '*)))
               (bv      (u8-list->bytevector input)))
          (qsort (bytevector->pointer bv) (bytevector-length bv) 1
                 (procedure->pointer int cmp (list '* '*)))
          #f)
        (throw 'unresolved)))

  (pass-if "bijection"
    (if (defined? 'procedure->pointer)
        (let* ((proc  (lambda (x y z)
                        (+ x y z 0.0)))
               (ret   double)
               (args  (list float int16 double))
               (proc* (pointer->procedure ret
                                          (procedure->pointer ret proc args)
                                          args))
               (arg1  (map (cut / <> 2.0) (iota 123)))
               (arg2  (iota 123 32000))
               (arg3  (map (cut / <> 4.0) (iota 123 100 4))))
          (equal? (map proc arg1 arg2 arg3)
                  (map proc* arg1 arg2 arg3)))
        (throw 'unresolved))))


(with-test-prefix "structs"

  (pass-if "sizeof { int8, double }"
    (= (sizeof (list int8 double))
       (+ (alignof double) (sizeof double))))

  (pass-if "sizeof { short, int, long, pointer }"
    (let ((layout (list short int long '*)))
      (>= (sizeof layout)
          (reduce + 0.0 (map sizeof layout)))))

  (pass-if "parse-c-struct"
    (let ((layout (list int64 uint8))
          (data   (list -300 43)))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data)))

  (pass-if "alignment constraints honored"
    (let ((layout (list int8 double))
          (data   (list -7 3.14)))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data)))

  (pass-if "int8, pointer"
    (let ((layout (list uint8 '*))
          (data   (list 222 (make-pointer 7777))))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data)))

  (pass-if "unsigned-long, int8, size_t"
    (let ((layout (list unsigned-long int8 size_t))
          (data   (list (expt 2 17) -128 (expt 2 18))))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data)))

  (pass-if "long, int, pointer"
    (let ((layout (list long int '*))
          (data   (list (- (expt 2 17)) -222 (make-pointer 777))))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data)))

  (pass-if "int8, pointer, short, double"
    (let ((layout (list int8 '* short double))
          (data   (list 77 %null-pointer -42 3.14)))
      (equal? (parse-c-struct (make-c-struct layout data)
                              layout)
              data))))