← Back to branch summary

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

« back to all changes in this revision

Viewing changes to testsuite/ffitest.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/ffitest.scm
 
1
;;;
 
2
;;; Test ffi
 
3
;;;
 
4
 
 
5
(use gauche.test)
 
6
 
 
7
(test-start "c-wrapper (ffi)")
 
8
(use c-wrapper)
 
9
(use gauche.uvector)
 
10
(use gauche.config)
 
11
(test-module 'c-wrapper)
 
12
 
 
13
(define DYLIB (string-append "./ffitest." (gauche-config "--dylib-suffix")))
 
14
(define dlopen (with-module c-wrapper dlopen))
 
15
(define dlclose (with-module c-wrapper dlclose))
 
16
(define dlsym (with-module c-wrapper dlsym))
 
17
(define ffi-type-uint (with-module c-wrapper ffi-type-uint))
 
18
(define ffi-type-sint (with-module c-wrapper ffi-type-sint))
 
19
(define ffi-type-pointer (with-module c-wrapper ffi-type-pointer))
 
20
(define ffi-prep-cif (with-module c-wrapper ffi-prep-cif))
 
21
(define ffi-call (with-module c-wrapper ffi-call))
 
22
(define ffi-prep-closure (with-module c-wrapper ffi-prep-closure))
 
23
 
 
24
(test "dlopen"
 
25
      #f
 
26
      (lambda ()
 
27
        (let ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW))))
 
28
          (begin0
 
29
            (null-ptr? handle)
 
30
            (dlclose handle)))))
 
31
          
 
32
 
 
33
(test "dlsym"
 
34
      #f
 
35
      (lambda ()
 
36
        (let* ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW)))
 
37
               (ptr (dlsym handle "add_uint")))
 
38
          (begin0
 
39
            (null-ptr? ptr)
 
40
            (dlclose handle)))))
 
41
 
 
42
(test "ffi_prep_cif"
 
43
      (with-module c-wrapper FFI_OK)
 
44
      (lambda ()
 
45
        (let* ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW)))
 
46
               (fn (dlsym handle "add_uint")))
 
47
          (receive (status cif)
 
48
              (ffi-prep-cif (ffi-type-uint) (list (ffi-type-uint)
 
49
                                                  (ffi-type-uint)))
 
50
            (begin0
 
51
              status
 
52
              (dlclose handle))))))
 
53
 
 
54
(test "ffi_call"
 
55
      3
 
56
      (lambda ()
 
57
        (let* ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW)))
 
58
               (fn (dlsym handle "add_uint"))
 
59
               (rvalue (make <c-uint>))
 
60
               (v1 (make <c-uint>))
 
61
               (v2 (make <c-uint>)))
 
62
          (receive (status cif)
 
63
              (ffi-prep-cif (ffi-type-sint) (list (ffi-type-uint)
 
64
                                                  (ffi-type-uint)))
 
65
            (v1 1)
 
66
            (v2 2)
 
67
            (ffi-call cif fn (ptr rvalue)
 
68
                      (list (ptr v1) (ptr v2)))
 
69
            (begin0
 
70
              (rvalue)
 
71
              (dlclose handle))))))
 
72
 
 
73
(test "ffi_closure"
 
74
      #t
 
75
      (lambda ()
 
76
        (let* ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW)))
 
77
               (fn (dlsym handle "callback")))
 
78
          (receive (status cif)
 
79
              (ffi-prep-cif (ffi-type-sint) (list (ffi-type-sint)
 
80
                                                  (ffi-type-sint)))
 
81
            (receive (status closure)
 
82
                (ffi-prep-closure cif (lambda (v1 v2)
 
83
                                        (let ((result (make <c-int>)))
 
84
                                          (result
 
85
                                                        (+ ((deref (cast (ptr <c-int>) v1)))
 
86
                                                           ((deref (cast (ptr <c-int>) v2)))))
 
87
 
 
88
                                          (ptr result))))
 
89
              (begin0
 
90
                (and (= status (with-module c-wrapper FFI_OK)) (not (null-ptr? closure)))
 
91
                (dlclose handle)))))))
 
92
 
 
93
(test "call callback"
 
94
      5
 
95
      (lambda ()
 
96
        (let* ((handle (dlopen DYLIB (with-module c-wrapper RTLD_NOW)))
 
97
               (fn (dlsym handle "callback_sint"))
 
98
               (v1 (make <c-int>))
 
99
               (v2 (make <c-int>))
 
100
               (rvalue (make <c-int>)))
 
101
          (receive (status cif_closure)
 
102
              (ffi-prep-cif (ffi-type-sint) (list (ffi-type-sint)
 
103
                                                  (ffi-type-sint)))
 
104
            (receive (status closure)
 
105
                (ffi-prep-closure cif_closure
 
106
                                  (lambda (v1 v2)
 
107
                                    (let ((result (make <c-int>)))
 
108
                                      (result
 
109
                                                    (+ ((deref (cast (ptr <c-int>) v1)))
 
110
                                                       ((deref (cast (ptr <c-int>) v2)))))
 
111
                                      (ptr result))))
 
112
              (receive (status cif)
 
113
                  (ffi-prep-cif (ffi-type-sint) (list (ffi-type-pointer)
 
114
                                                      (ffi-type-sint)
 
115
                                                      (ffi-type-sint)))
 
116
                (v1 -3)
 
117
                (v2 8)
 
118
                (ffi-call cif fn (ptr rvalue) (list (ptr closure)
 
119
                                                    (ptr v1)
 
120
                                                    (ptr v2)))
 
121
                (begin0
 
122
                  (rvalue)
 
123
                  (dlclose handle))))))))
 
124
 
 
125
;; epilogue
 
126
(test-end)
 
127