← Back to branch summary

~ubuntu-branches/ubuntu/lucid/gauche-c-wrapper/lucid

« back to all changes in this revision

Viewing changes to testsuite/cwrappertest.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2008-04-07 09:15:03 UTC
  • Revision ID: james.westby@ubuntu.com-20080407091503-wu0h414koe95kj4i
Tags: upstream-0.5.2
Import upstream version 0.5.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
testsuite/cwrappertest.scm
 
1
;;;
 
2
;;; Test c-wrapper
 
3
;;;
 
4
 
 
5
(use gauche.test)
 
6
 
 
7
(test-start "c-wrapper")
 
8
(use c-wrapper)
 
9
(use gauche.sequence)
 
10
(test-module 'c-wrapper)
 
11
 
 
12
(c-load-library "./ffitest")
 
13
(c-include "./ffitest.h")
 
14
 
 
15
(define-syntax test-cfunc
 
16
  (syntax-rules ()
 
17
    ((_ expected func v1 v2)
 
18
     (test (symbol->string 'func)
 
19
           expected
 
20
           (lambda ()
 
21
               (func v1 v2))))))
 
22
 
 
23
(test-cfunc 3 add_uchar 2 1)
 
24
(test-cfunc 3 add_ushort 2 1)
 
25
(test-cfunc 3 add_uint 2 1)
 
26
(test-cfunc 3 add_ulong 2 1)
 
27
(test-cfunc 3 add_ulonglong 2 1)
 
28
(test-cfunc -1 add_schar -2 1)
 
29
(test-cfunc -1 add_sshort -2 1)
 
30
(test-cfunc -1 add_sint -2 1)
 
31
(test-cfunc -1 add_slong -2 1)
 
32
(test-cfunc -1 add_slonglong -2 1)
 
33
(test-cfunc 2.5 add_float 5 -2.5)
 
34
(test-cfunc 2.5 add_double 5 -2.5)
 
35
(test "add_string"
 
36
      "Hello, world"
 
37
      (lambda ()
 
38
        (x->string (add_string "Hello, " "world"))))
 
39
 
 
40
(define-syntax test-carray
 
41
  (syntax-rules ()
 
42
    ((_ expected func c-type class v1 v2)
 
43
     (test (symbol->string 'func)
 
44
           expected
 
45
           (lambda ()
 
46
             (map (cut cast class <>)
 
47
                  (cast (c-type (length v1))
 
48
                        (func (length v1) v1 v2))))))))
 
49
 
 
50
(test-carray '(5 7 9) add_array_uchar <c-uchar> <real> '(1 2 3) '(4 5 6))
 
51
(test-carray '(5 7 9) add_array_ushort <c-ushort> <real> '(1 2 3) '(4 5 6))
 
52
(test-carray '(5 7 9) add_array_uint <c-uint> <real> '(1 2 3) '(4 5 6))
 
53
(test-carray '(5 7 9) add_array_ulong <c-ulong> <real> '(1 2 3) '(4 5 6))
 
54
(test-carray '(5 7 9) add_array_ulonglong <c-ulonglong> <real>
 
55
             '(1 2 3) '(4 5 6))
 
56
 
 
57
(test-carray '(5 -7 9) add_array_schar <c-char> <real> '(1 2 3) '(4 -9 6))
 
58
(test-carray '(5 -7 9) add_array_sshort <c-short> <real> '(1 2 3) '(4 -9 6))
 
59
(test-carray '(5 -7 9) add_array_sint <c-int> <real> '(1 2 3) '(4 -9 6))
 
60
(test-carray '(5 -7 9) add_array_slong <c-long> <real> '(1 2 3) '(4 -9 6))
 
61
(test-carray '(5 -7 9) add_array_slonglong <c-longlong> <real>
 
62
             '(1 2 3) '(4 -9 6))
 
63
(test-carray '(-0.5 0.0 0.5) add_array_float <c-float> <real>
 
64
             '(-1 1.5 1.75) '(0.5 -1.5 -1.25))
 
65
(test-carray '(-0.5 0.0 0.5) add_array_double <c-double> <real>
 
66
             '(-1 1.5 1.75) '(0.5 -1.5 -1.25))
 
67
(test-carray '("foo1" "bar2" "baz3") add_array_string (ptr <c-uchar>) <string>
 
68
             '("foo" "bar" "baz") '("1" "2" "3"))
 
69
 
 
70
(define-syntax test-cstruct
 
71
  (syntax-rules ()
 
72
    ((_ expected func tagname class v1 v2)
 
73
     (test (symbol->string 'func)
 
74
           expected
 
75
           (lambda ()
 
76
             (let ((s1 (make tagname))
 
77
                   (s2 (make tagname)))
 
78
               (set! (ref s1 'value) v1)
 
79
               (set! (ref s2 'value) v2)
 
80
               (cast class (ref (func s1 s2) 'value))))))))
 
81
 
 
82
(test-cstruct 3 add_struct_uchar (c-struct 'test_uchar) <real> 2 1)
 
83
(test-cstruct 3 add_struct_ushort (c-struct 'test_ushort) <real> 2 1)
 
84
(test-cstruct 3 add_struct_uint (c-struct 'test_uint) <real> 2 1)
 
85
(test-cstruct 3 add_struct_ulong (c-struct 'test_ulong) <real> 2 1)
 
86
(test-cstruct 3 add_struct_ulonglong (c-struct 'test_ulonglong) <real> 2 1)
 
87
(test-cstruct -1 add_struct_schar (c-struct 'test_schar) <real> -2 1)
 
88
(test-cstruct -1 add_struct_sshort (c-struct 'test_sshort) <real> -2 1)
 
89
(test-cstruct -1 add_struct_sint (c-struct 'test_sint) <real> -2 1)
 
90
(test-cstruct -1 add_struct_slong (c-struct 'test_slong) <real> -2 1)
 
91
(test-cstruct -1 add_struct_slonglong (c-struct 'test_slonglong) <real> -2 1)
 
92
(test-cstruct 1.5 add_struct_float (c-struct 'test_float) <real> 1.75 -0.25)
 
93
(test-cstruct 1.5 add_struct_double (c-struct 'test_double) <real> 1.75 -0.25)
 
94
(test-cstruct "Hello, world" add_struct_string (c-struct 'test_string) <string>
 
95
              "Hello, " "world")
 
96
 
 
97
(define-syntax test-cstruct-array
 
98
  (syntax-rules ()
 
99
    ((_ expected func tagname class v1 v2)
 
100
     (test (symbol->string 'func)
 
101
           expected
 
102
           (lambda ()
 
103
             (let* ((s1 (make tagname))
 
104
                    (s2 (make tagname)))
 
105
               (set! (ref s1 'value) v1)
 
106
               (set! (ref s2 'value) v2)
 
107
               (map (cut cast class <>)
 
108
                    (ref (func s1 s2) 'value))))))))
 
109
 
 
110
(test-cstruct-array '(5 7 9) add_struct_array_ushort
 
111
                    (c-struct 'test_array_ushort)
 
112
                    <real>
 
113
                    '(1 2 3) '(4 5 6))
 
114
(test-cstruct-array '(5 7 9) add_struct_array_uint
 
115
                    (c-struct 'test_array_uint)
 
116
                    <real>
 
117
                    '(1 2 3) '(4 5 6))
 
118
(test-cstruct-array '(5 7 9) add_struct_array_ulong
 
119
                    (c-struct 'test_array_ulong)
 
120
                    <real>
 
121
                    '(1 2 3) '(4 5 6))
 
122
(test-cstruct-array '(5 7 9) add_struct_array_ulonglong
 
123
                    (c-struct 'test_array_ulonglong)
 
124
                    <real>
 
125
                    '(1 2 3) '(4 5 6))
 
126
(test-cstruct-array '(5 -7 9) add_struct_array_schar
 
127
                    (c-struct 'test_array_schar)
 
128
                    <real>
 
129
                    '(1 2 3) '(4 -9 6))
 
130
(test-cstruct-array '(5 -7 9) add_struct_array_sshort
 
131
                    (c-struct 'test_array_sshort)
 
132
                    <real>
 
133
                    '(1 2 3) '(4 -9 6))
 
134
(test-cstruct-array '(5 -7 9) add_struct_array_sint
 
135
                    (c-struct 'test_array_sint)
 
136
                    <real>
 
137
                    '(1 2 3) '(4 -9 6))
 
138
(test-cstruct-array '(5 -7 9) add_struct_array_slong
 
139
                    (c-struct 'test_array_slong)
 
140
                    <real>
 
141
                    '(1 2 3) '(4 -9 6))
 
142
(test-cstruct-array '(5 -7 9) add_struct_array_slonglong
 
143
                    (c-struct 'test_array_slonglong)
 
144
                    <real>
 
145
                    '(1 2 3) '(4 -9 6))
 
146
(test-cstruct-array '(-0.5 0.0 0.5) add_struct_array_float
 
147
                    (c-struct 'test_array_float)
 
148
                    <real>
 
149
                    '(-1 1.5 1.75) '(0.5 -1.5 -1.25))
 
150
(test-cstruct-array '(-0.5 0.0 0.5) add_struct_array_double
 
151
                    (c-struct 'test_array_double)
 
152
                    <real>
 
153
                    '(-1 1.5 1.75) '(0.5 -1.5 -1.25))
 
154
(test-cstruct-array '("foo1" "bar2" "baz3") add_struct_array_string
 
155
                    (c-struct 'test_array_string)
 
156
                    <string>
 
157
                    '("foo" "bar" "baz") '("1" "2" "3"))
 
158
 
 
159
(define-syntax test-cclosure
 
160
  (syntax-rules ()
 
161
    ((_ expected func v1 v2)
 
162
     (test (symbol->string 'func)
 
163
           expected
 
164
           (lambda ()
 
165
               (func + v1 v2))))))
 
166
 
 
167
(test-cclosure 3 callback_uchar 2 1)
 
168
(test-cclosure 3 callback_ushort 2 1)
 
169
(test-cclosure 3 callback_uint 2 1)
 
170
(test-cclosure 3 callback_ulong 2 1)
 
171
(test-cclosure 3 callback_ulonglong 2 1)
 
172
(test-cclosure -1 callback_schar -2 1)
 
173
(test-cclosure -1 callback_sshort -2 1)
 
174
(test-cclosure -1 callback_sint -2 1)
 
175
(test-cclosure -1 callback_slong -2 1)
 
176
(test-cclosure -1 callback_slonglong -2 1)
 
177
(test-cclosure 2.5 callback_float 5 -2.5)
 
178
(test-cclosure 2.5 callback_double 5 -2.5)
 
179
(test "callback_string"
 
180
      "Hello, world"
 
181
      (lambda ()
 
182
        (x->string (callback_string (lambda (a1 a2)
 
183
                                      (string-append (x->string a1)
 
184
                                                     (x->string a2)))
 
185
                                    "Hello, " "world"))))
 
186
 
 
187
(define-syntax test-vaarg
 
188
  (syntax-rules ()
 
189
    ((_ expected func in-c-type out-c-type class)
 
190
     (test (symbol->string 'func)
 
191
           expected
 
192
           (lambda ()
 
193
             (let* ((array-class (out-c-type (length expected))))
 
194
               (map (cut cast class <>)
 
195
                    (cast array-class
 
196
                          (apply func (length expected)
 
197
                                 (map (cut cast in-c-type <>)
 
198
                                      expected))))))))))
 
199
 
 
200
(test-vaarg '(1 2 3) vaarg_uint <c-uint> <c-uint> <real>)
 
201
(test-vaarg '(1 2 3) vaarg_ulong <c-ulong> <c-ulong> <real>)
 
202
(test-vaarg '(1 2 3) vaarg_ulonglong <c-ulonglong> <c-ulonglong> <real>)
 
203
(test-vaarg '(1 -2 3) vaarg_sint <c-int> <c-int> <real>)
 
204
(test-vaarg '(1 -2 3) vaarg_slong <c-long> <c-long> <real>)
 
205
(test-vaarg '(1 -2 3) vaarg_slonglong <c-longlong> <c-longlong> <real>)
 
206
(test-vaarg '(-0.5 0.0 0.5) vaarg_double <c-double> <c-double> <real>)
 
207
(test-vaarg '("foo" "bar" "baz") vaarg_string
 
208
            (ptr <c-uchar>) (ptr <c-uchar>) <string>)
 
209
 
 
210
(define-syntax test-union
 
211
  (syntax-rules ()
 
212
    ((_ expected func class name v1 v2)
 
213
     (test (symbol->string 'func)
 
214
           expected
 
215
           (lambda ()
 
216
             (let ((u1 (make (c-union 'test)))
 
217
                   (u2 (make (c-union 'test))))
 
218
               (set! (ref u1 name) v1)
 
219
               (set! (ref u2 name) v2)
 
220
               (cast class (ref (func u1 u2) name))))))))
 
221
 
 
222
(test-union -10 test_union_c <real> 'c -15 5)
 
223
(test-union -10 test_union_s <real> 's -9 -1)
 
224
(test-union -10 test_union_i <real> 'i 20 -30)
 
225
(test-union -10 test_union_l <real> 'l 10000000 -10000010)
 
226
(test-union -10 test_union_ll <real> 'll 0 -10)
 
227
(test-union -1.75 test_union_f <real> 'f -1 -0.75)
 
228
(test-union 0.5 test_union_d <real> 'd 3.75 -3.25)
 
229
(test-union "foobar" test_union_str <string> 'str "foo" "bar")
 
230
 
 
231
(test "test_var"
 
232
      '(-1 -2 -3 -4 -5 5 4 3 2 1 -0.5 0.5 "foobar")
 
233
      (lambda ()
 
234
        (set! (ref var_char) -2)
 
235
        (set! (ref var_short) -3)
 
236
        (set! (ref var_int) -4)
 
237
        (set! (ref var_long) -5)
 
238
        (set! (ref var_longlong) -6)
 
239
        (set! (ref var_uchar) 4)
 
240
        (set! (ref var_ushort) 3)
 
241
        (set! (ref var_uint) 2)
 
242
        (set! (ref var_ulong) 1)
 
243
        (set! (ref var_ulonglong) 0)
 
244
        (set! (ref var_float) -1.75)
 
245
        (set! (ref var_double) -0.75)
 
246
        (set! (ref var_string) "foo")
 
247
        (test_var)
 
248
        (list (ref var_char)
 
249
              (ref var_short)
 
250
              (ref var_int)
 
251
              (ref var_long)
 
252
              (ref var_longlong)
 
253
              (ref var_uchar)
 
254
              (ref var_ushort)
 
255
              (ref var_uint)
 
256
              (ref var_ulong)
 
257
              (ref var_ulonglong)
 
258
              (ref var_float)
 
259
              (ref var_double)
 
260
              (x->string var_string))))
 
261
 
 
262
(test "incomplete_array(ref)"
 
263
      '(1 -2 123)
 
264
      (lambda ()
 
265
        (list (ref incomplete_array 0)
 
266
              (ref incomplete_array 1)
 
267
              (ref incomplete_array 2))))
 
268
 
 
269
(test "incomplete_array(set!)"
 
270
      '(5 -2 -321)
 
271
      (lambda ()
 
272
        (set! (ref incomplete_array 0) 5)
 
273
        (set! (ref incomplete_array 2) -321)
 
274
        (list (ref incomplete_array 0)
 
275
              (ref incomplete_array 1)
 
276
              (ref incomplete_array 2))))
 
277
 
 
278
(test "test_null_ptr (make-null-ptr)"
 
279
      #t
 
280
      (lambda ()
 
281
        (not (= 0 (test_null_ptr (make-null-ptr))))))
 
282
 
 
283
(test "test_null_ptr (0)"
 
284
      #t
 
285
      (lambda ()
 
286
        (not (= 0 (test_null_ptr 0)))))
 
287
 
 
288
(test "test_null_func_ptr (make-null-ptr)"
 
289
      #t
 
290
      (lambda ()
 
291
        (not (= 0 (test_null_func_ptr (make-null-ptr))))))
 
292
 
 
293
(test "test_null_func_ptr (0)"
 
294
      #t
 
295
      (lambda ()
 
296
        (not (= 0 (test_null_func_ptr 0)))))
 
297
 
 
298
(test "test post++"
 
299
      '(3 4)
 
300
      (lambda ()
 
301
        (c-value-set! test_val 3)
 
302
        (let ((x (post_pp test_val)))
 
303
          (list x (test_val)))))
 
304
 
 
305
(test "test post--"
 
306
      '(3 2)
 
307
      (lambda ()
 
308
        (c-value-set! test_val 3)
 
309
        (let ((x (post_mm test_val)))
 
310
          (list x (test_val)))))
 
311
 
 
312
(test "test pre++"
 
313
      '(4 4)
 
314
      (lambda ()
 
315
        (c-value-set! test_val 3)
 
316
        (let ((x (pre_pp test_val)))
 
317
          (list x (test_val)))))
 
318
 
 
319
(test "test pre--"
 
320
      '(2 2)
 
321
      (lambda ()
 
322
        (c-value-set! test_val 3)
 
323
        (let ((x (pre_mm test_val)))
 
324
          (list x (test_val)))))
 
325
 
 
326
(test "test post++ (pointer)"
 
327
      '(-2 -1)
 
328
      (lambda ()
 
329
        (init_test_ptr)
 
330
        (let ((x (post_pp test_ptr)))
 
331
          (list ((deref x)) ((deref test_ptr))))))
 
332
 
 
333
(test "test post-- (pointer)"
 
334
      '(-1 -2)
 
335
      (lambda ()
 
336
        (init_test_ptr)
 
337
        (post++ test_ptr)
 
338
        (let ((x (post_mm test_ptr)))
 
339
          (list ((deref x)) ((deref test_ptr))))))
 
340
 
 
341
(test "test pre++ (pointer)"
 
342
      '(-1 -1)
 
343
      (lambda ()
 
344
        (init_test_ptr)
 
345
        (let ((x (pre_pp test_ptr)))
 
346
          (list ((deref x)) ((deref test_ptr))))))
 
347
 
 
348
(test "test pre-- (pointer)"
 
349
      '(-2 -2)
 
350
      (lambda ()
 
351
        (init_test_ptr)
 
352
        (pre++ test_ptr)
 
353
        (let ((x (pre_mm test_ptr)))
 
354
          (list ((deref x)) ((deref test_ptr))))))
 
355
 
 
356
(test "test plus (value)"
 
357
      5
 
358
      (lambda ()
 
359
        (plus 2 3)))
 
360
 
 
361
(test "test minus (value)"
 
362
      3
 
363
      (lambda ()
 
364
        (let ((v1 (make <c-int>))
 
365
              (v2 (make <c-int>)))
 
366
          (v1 5)
 
367
          (v2 2)
 
368
        (minus v1 v2))))
 
369
 
 
370
(test "test plus (pointer)"
 
371
      1
 
372
      (lambda ()
 
373
        (init_test_ptr)
 
374
        ((deref (plus test_ptr 3)))))
 
375
 
 
376
(test "test minus (pointer)"
 
377
      -1
 
378
      (lambda ()
 
379
        (init_test_ptr)
 
380
        ((deref (minus (plus test_ptr 3) 2)))))
 
381
 
 
382
(test "test bitfield"
 
383
      '(-2 2 2 -30001 3)
 
384
      (lambda ()
 
385
        (let ((dat (make (c-struct 'bitfield_rec))))
 
386
          (c-struct-set! dat 'v1 -1)
 
387
          (c-struct-set! dat 'v2 1)
 
388
          (c-struct-set! dat 'v3 1)
 
389
          (c-struct-set! dat 'v4 -30000)
 
390
          (c-struct-set! dat 'v5 2)
 
391
          (let ((newdat (test_bitfield dat)))
 
392
            (list (c-struct-ref newdat 'v1)
 
393
                  (c-struct-ref newdat 'v2)
 
394
                  (c-struct-ref newdat 'v3)
 
395
                  (c-struct-ref newdat 'v4)
 
396
                  (c-struct-ref newdat 'v5))))))
 
397
 
 
398
(test "test macro function #1"
 
399
      '(1 0)
 
400
      (lambda ()
 
401
        (let ((v1 (make <c-int>))
 
402
              (v2 (make <c-int>)))
 
403
          (v1 0)
 
404
          (v2 0)
 
405
          (IFMAC 1 (post++ v1) (post++ v2))
 
406
          (list (v1) (v2)))))
 
407
 
 
408
(test "test macro function #2"
 
409
      '(0 1)
 
410
      (lambda ()
 
411
        (let ((v1 (make <c-int>))
 
412
              (v2 (make <c-int>)))
 
413
          (v1 0)
 
414
          (v2 0)
 
415
          (IFMAC 0 (post++ v1) (post++ v2))
 
416
          (list (v1) (v2)))))
 
417
 
 
418
(test "test function parameter"
 
419
      "foobar"
 
420
      (lambda ()
 
421
        (x->string (param_func_test malloc))))
 
422
 
 
423
(test "test dereference of a function pointer"
 
424
      3
 
425
      (lambda ()
 
426
        ((deref (get_fptr)) 1 2)))
 
427
 
 
428
(test "object-apply of a function pointer"
 
429
      3
 
430
      (lambda ()
 
431
        ((get_fptr) 1 2)))
 
432
 
 
433
;; epilogue
 
434
(test-end)
 
435