Commit | Line | Data |
---|---|---|
01ad5a7b LC |
1 | ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
3 | ;;;; Copyright (C) 2010 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) | |
07d22c02 | 25 | #:use-module (rnrs bytevectors) |
d4149a51 | 26 | #:use-module (srfi srfi-1) |
01ad5a7b LC |
27 | #:use-module (test-suite lib)) |
28 | ||
29 | \f | |
30 | (with-test-prefix "null pointer" | |
31 | ||
32 | (pass-if "zero" | |
5b46a8c2 | 33 | (= 0 (pointer-address %null-pointer))) |
01ad5a7b | 34 | |
d4149a51 LC |
35 | (pass-if "null pointer identity" |
36 | (eq? %null-pointer (make-pointer 0))) | |
37 | ||
38 | (pass-if "null-pointer? %null-pointer" | |
39 | (null-pointer? %null-pointer)) | |
01ad5a7b | 40 | |
5b46a8c2 | 41 | (pass-if-exception "pointer->bytevector %null-pointer" |
01ad5a7b | 42 | exception:null-pointer-error |
5b46a8c2 | 43 | (pointer->bytevector %null-pointer 7))) |
01ad5a7b | 44 | |
d4149a51 LC |
45 | \f |
46 | (with-test-prefix "make-pointer" | |
47 | ||
48 | (pass-if "address preserved" | |
5b46a8c2 | 49 | (= 123 (pointer-address (make-pointer 123))))) |
d4149a51 LC |
50 | |
51 | \f | |
5b46a8c2 | 52 | (with-test-prefix "pointer<->bytevector" |
d4149a51 LC |
53 | |
54 | (pass-if "bijection" | |
55 | (let ((bv #vu8(0 1 2 3 4 5 6 7))) | |
5b46a8c2 | 56 | (equal? (pointer->bytevector (bytevector->pointer bv) |
d4149a51 LC |
57 | (bytevector-length bv)) |
58 | bv))) | |
59 | ||
60 | (pass-if "pointer from bits" | |
61 | (let* ((bytes (iota (sizeof '*))) | |
62 | (bv (u8-list->bytevector bytes))) | |
5b46a8c2 | 63 | (= (pointer-address |
d4149a51 LC |
64 | (make-pointer (bytevector-uint-ref bv 0 (native-endianness) |
65 | (sizeof '*)))) | |
17fc9efe LC |
66 | (fold-right (lambda (byte address) |
67 | (+ byte (* 256 address))) | |
68 | 0 | |
69 | bytes)))) | |
70 | ||
71 | (pass-if "dereference-pointer" | |
72 | (let* ((bytes (iota (sizeof '*))) | |
73 | (bv (u8-list->bytevector bytes))) | |
5b46a8c2 LC |
74 | (= (pointer-address |
75 | (dereference-pointer (bytevector->pointer bv))) | |
d4149a51 LC |
76 | (fold-right (lambda (byte address) |
77 | (+ byte (* 256 address))) | |
78 | 0 | |
79 | bytes))))) | |
7387c231 LC |
80 | |
81 | \f | |
fa2a89a6 LC |
82 | (with-test-prefix "pointer<->string" |
83 | ||
84 | (pass-if "bijection" | |
85 | (let ((s "hello, world")) | |
86 | (string=? s (pointer->string (string->pointer s))))) | |
87 | ||
88 | (pass-if "bijection [latin1]" | |
89 | (with-latin1-locale | |
90 | (let ((s "Szép jó napot!")) | |
91 | (string=? s (pointer->string (string->pointer s))))))) | |
92 | ||
93 | \f | |
33186356 LC |
94 | (with-test-prefix "procedure->pointer" |
95 | ||
96 | (define qsort | |
97 | ;; Bindings for libc's `qsort' function. | |
98 | (make-foreign-function void | |
99 | (dynamic-func "qsort" (dynamic-link)) | |
100 | (list '* size_t size_t '*))) | |
101 | ||
102 | (define (dereference-pointer-to-byte ptr) | |
103 | (let ((b (pointer->bytevector ptr 1))) | |
104 | (bytevector-u8-ref b 0))) | |
105 | ||
106 | (define input | |
107 | '(7 1 127 3 5 4 77 2 9 0)) | |
108 | ||
109 | (pass-if "qsort" | |
110 | (if (defined? 'procedure->pointer) | |
111 | (let* ((called? #f) | |
112 | (cmp (lambda (x y) | |
113 | (set! called? #t) | |
114 | (- (dereference-pointer-to-byte x) | |
115 | (dereference-pointer-to-byte y)))) | |
116 | (ptr (procedure->pointer int cmp (list '* '*))) | |
117 | (bv (u8-list->bytevector input))) | |
118 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
119 | (procedure->pointer int cmp (list '* '*))) | |
120 | (and called? | |
121 | (equal? (bytevector->u8-list bv) | |
122 | (sort input <)))) | |
123 | (throw 'unresolved))) | |
124 | ||
125 | (pass-if-exception "qsort, wrong return type" | |
126 | exception:wrong-type-arg | |
127 | ||
128 | (if (defined? 'procedure->pointer) | |
129 | (let* ((cmp (lambda (x y) #f)) ; wrong return type | |
130 | (ptr (procedure->pointer int cmp (list '* '*))) | |
131 | (bv (u8-list->bytevector input))) | |
132 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
133 | (procedure->pointer int cmp (list '* '*))) | |
134 | #f) | |
135 | (throw 'unresolved))) | |
136 | ||
137 | (pass-if-exception "qsort, wrong arity" | |
138 | exception:wrong-num-args | |
139 | ||
140 | (if (defined? 'procedure->pointer) | |
141 | (let* ((cmp (lambda (x y z) #f)) ; wrong arity | |
142 | (ptr (procedure->pointer int cmp (list '* '*))) | |
143 | (bv (u8-list->bytevector input))) | |
144 | (qsort (bytevector->pointer bv) (bytevector-length bv) 1 | |
145 | (procedure->pointer int cmp (list '* '*))) | |
146 | #f) | |
147 | (throw 'unresolved)))) | |
148 | ||
149 | \f | |
7387c231 LC |
150 | (with-test-prefix "structs" |
151 | ||
152 | (pass-if "parse-c-struct" | |
153 | (let ((layout (list int64 uint8)) | |
154 | (data (list -300 43))) | |
155 | (equal? (parse-c-struct (make-c-struct layout data) | |
156 | layout) | |
157 | data)))) |