← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/c-ffilib.stub

  • 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:
src/c-ffilib.stub
 
1
;; -*- coding: utf-8; mode: scheme -*-
 
2
;;
 
3
;; ffilib.stub
 
4
;; 
 
5
;;  Copyright (c) 2006 KOGURO, Naoki (naoki@koguro.net)
 
6
;; 
 
7
;;  Permission is hereby granted, free of charge, to any person 
 
8
;;  obtaining a copy of this software and associated 
 
9
;;  documentation files (the "Software"), to deal in the 
 
10
;;  Software without restriction, including without limitation 
 
11
;;  the rights to use, copy, modify, merge, publish, distribute, 
 
12
;;  sublicense, and/or sell copies of the Software, and to 
 
13
;;  permit persons to whom the Software is furnished to do so, 
 
14
;;  subject to the following conditions:
 
15
;; 
 
16
;;  The above copyright notice and this permission notice shall 
 
17
;;  be included in all copies or substantial portions of the 
 
18
;;  Software.
 
19
;; 
 
20
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY 
 
21
;;  KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE 
 
22
;;  WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 
 
23
;;  PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS 
 
24
;;  OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
 
25
;;  OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR 
 
26
;;  OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 
 
27
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
28
;; 
 
29
;;  $Id: c-ffilib.stub 379 2007-01-02 13:58:58Z naoki $
 
30
 
 
31
"
 
32
#include \"c-ffi.h\"
 
33
"
 
34
(define-enum FFI_OK)
 
35
(define-enum FFI_BAD_TYPEDEF)
 
36
(define-enum FFI_BAD_ABI)
 
37
 
 
38
(define-type <ffi-type>
 
39
  "ffi_type*"         ; c-type
 
40
  "ffi_type"          ; description
 
41
  "SCM_FFI_TYPEP"     ; c-predicate
 
42
  "SCM_FFI_TYPE_DATA" ; unboxer
 
43
  "SCM_MAKE_FFI_TYPE" ; boxer
 
44
  )
 
45
 
 
46
(define-type <ffi-cif>
 
47
  "ffi_cif*"         ; c-type
 
48
  "ffi_cif"          ; description
 
49
  "SCM_FFI_CIFP"     ; c-predicate
 
50
  "SCM_FFI_CIF_DATA" ; unboxer
 
51
  "SCM_MAKE_FFI_CIF" ; boxer
 
52
  )
 
53
 
 
54
(define-type <ffi-closure>
 
55
  "ffi_closure*"         ; c-type
 
56
  "ffi_closure"          ; description
 
57
  "SCM_FFI_CLOSUREP"     ; c-predicate
 
58
  "SCM_FFI_CLOSURE_DATA" ; unboxer
 
59
  "SCM_MAKE_FFI_CLOSURE" ; boxer
 
60
  )
 
61
 
 
62
(define-type <uvector> "ScmUVector*" #f "SCM_UVECTORP" "SCM_UVECTOR")
 
63
 
 
64
(define-cclass <ffi-type> :built-in
 
65
  "ScmFFIType*" "Scm_FFITypeClass"
 
66
  ()
 
67
  ((size :type <long>)
 
68
   (alignment :type <ushort>)
 
69
   (type :type <ushort>)))
 
70
 
 
71
(define-cclass <ffi-cif> :built-in
 
72
  "ScmFFICif*" "Scm_FFICifClass"
 
73
  ()
 
74
  ())
 
75
 
 
76
(define-cclass <ffi-closure> :built-in
 
77
  "ScmFFIClosure*" "Scm_FFIClosureClass"
 
78
  ()
 
79
  ())
 
80
 
 
81
(define-cproc ffi-type-void ()
 
82
  (code "SCM_RETURN(SCM_MAKE_FFI_TYPE(&ffi_type_void));"))
 
83
 
 
84
(define-cproc ffi-type-float ()
 
85
  (code "SCM_RETURN(SCM_MAKE_FFI_TYPE(&ffi_type_float));"))
 
86
 
 
87
(define-cproc ffi-type-double ()
 
88
  (code "SCM_RETURN(SCM_MAKE_FFI_TYPE(&ffi_type_double));"))
 
89
 
 
90
(define-cproc ffi-type-longdouble ()
 
91
  (code "SCM_RETURN(SCM_MAKE_FFI_TYPE(&ffi_type_longdouble));"))
 
92
 
 
93
(define-cproc ffi-type-pointer ()
 
94
  (code "SCM_RETURN(SCM_MAKE_FFI_TYPE(&ffi_type_pointer));"))
 
95
 
 
96
(define-cproc ffi-type-uchar ()
 
97
  (code "SCM_RETURN(Scm_GetUnsignedFFIType(sizeof(unsigned char)));"))
 
98
 
 
99
(define-cproc ffi-type-schar ()
 
100
  (code "SCM_RETURN(Scm_GetSignedFFIType(sizeof(signed char)));"))
 
101
 
 
102
(define-cproc ffi-type-ushort ()
 
103
  (code "SCM_RETURN(Scm_GetUnsignedFFIType(sizeof(unsigned short)));"))
 
104
 
 
105
(define-cproc ffi-type-sshort ()
 
106
  (code "SCM_RETURN(Scm_GetSignedFFIType(sizeof(signed short)));"))
 
107
 
 
108
(define-cproc ffi-type-uint ()
 
109
  (code "SCM_RETURN(Scm_GetUnsignedFFIType(sizeof(unsigned int)));"))
 
110
 
 
111
(define-cproc ffi-type-sint ()
 
112
  (code "SCM_RETURN(Scm_GetSignedFFIType(sizeof(signed int)));"))
 
113
 
 
114
(define-cproc ffi-type-ulong ()
 
115
  (code "SCM_RETURN(Scm_GetUnsignedFFIType(sizeof(unsigned long)));"))
 
116
 
 
117
(define-cproc ffi-type-slong ()
 
118
  (code "SCM_RETURN(Scm_GetSignedFFIType(sizeof(signed long)));"))
 
119
 
 
120
(define-cproc ffi-type-ulonglong ()
 
121
  (code "SCM_RETURN(Scm_GetUnsignedFFIType(sizeof(unsigned long long)));"))
 
122
 
 
123
(define-cproc ffi-type-slonglong ()
 
124
  (code "SCM_RETURN(Scm_GetSignedFFIType(sizeof(signed long long)));"))
 
125
 
 
126
(define-cproc ffi-prep-cif (rtype::<ffi-type> arglist::<list>)
 
127
  (call "Scm_FFIPrepCIF"))
 
128
 
 
129
(define-cproc make-ffi-array-type (type::<ffi-type> size::<long>)
 
130
  (call "Scm_MakeFFIArrayType"))
 
131
 
 
132
(define-cproc make-ffi-struct-type (elementlist::<list>)
 
133
  (call "Scm_MakeFFIStructType"))
 
134
 
 
135
(define-cproc ffi-call (cif::<ffi-cif> fnPtrObj rvaluePtrObj avalues::<list>)
 
136
  (call "Scm_FFICall"))
 
137
 
 
138
(define-cproc ffi-prep-closure (cif::<ffi-cif> proc::<procedure>)
 
139
  (call "Scm_FFIPrepClosure"))
 
140
 
 
141
 
 
142
;;
 
143
;; pointer
 
144
;;
 
145
(define-cproc make-u8vector-nonatomic (size::<fixnum>)
 
146
  (code "unsigned char *p = SCM_NEW2(unsigned char*, size);"
 
147
        "SCM_RETURN(Scm_MakeU8VectorFromArrayShared(size, p));"))
 
148
 
 
149
(define-cproc null-ptr? (ptr)
 
150
  (code "SCM_RETURN(SCM_MAKE_BOOL(BASIC_POINTERP(ptr) && POINTER_DATA(ptr) == NULL));"))
 
151
 
 
152
(define-cproc %ptr (obj)
 
153
  (code "SCM_RETURN(MAKE_POINTER(PTR_CLASS(SCM_CLASS_OF(obj)), SCM_UVECTOR_ELEMENTS(BUFFER_OF(obj))));"))
 
154
 
 
155
(define-cproc %ptr-uvector (ptrClass uvec::<uvector>)
 
156
  (code "SCM_RETURN(MAKE_POINTER(ptrClass, SCM_UVECTOR_ELEMENTS(uvec)));"))
 
157
 
 
158
(define-cproc %deref (ptrObj)
 
159
  (call "Scm_Deref"))
 
160
 
 
161
(define-cproc ptr->string (ptrObj)
 
162
  (code "SCM_RETURN(SCM_MAKE_STR_IMMUTABLE((const char*) POINTER_DATA(ptrObj)));"))
 
163
 
 
164
(define-cproc %expand-u8vector (buf::<uvector> size::<long>)
 
165
  (code "SCM_RETURN(Scm_MakeU8VectorFromArrayShared(size, SCM_U8VECTOR_ELEMENTS(buf)));"))
 
166
 
 
167
(define-cproc make-null-ptr ()
 
168
  (code "SCM_RETURN(MAKE_VOID_POINTER(NULL));"))
 
169
 
 
170
"
 
171
static void finalize_pointer(ScmObj obj, void *data)
 
172
{
 
173
    static ScmObj finalizeof_proc = SCM_FALSE;
 
174
    ScmObj finalize_proc;
 
175
 
 
176
    if (SCM_FALSEP(finalizeof_proc)) {
 
177
        finalizeof_proc = SCM_SYMBOL_VALUE(MODULE_NAME, \"finalizer-of\");
 
178
    }
 
179
 
 
180
    finalize_proc = Scm_ApplyRec(finalizeof_proc, SCM_LIST1(obj));
 
181
    if (!SCM_FALSEP(finalize_proc)) {
 
182
        Scm_ApplyRec(finalize_proc, SCM_LIST1(obj));
 
183
    }
 
184
    Scm_UnregisterFinalizer(obj);
 
185
}
 
186
"
 
187
 
 
188
(define-cproc %register-finalizer! (ptrobj)
 
189
  "if (!POINTERP(ptrobj)) {
 
190
      Scm_Error(\"<c-ptr> required, but got %S\", ptrobj);
 
191
  }
 
192
  Scm_RegisterFinalizer(ptrobj, finalize_pointer, NULL);
 
193
  SCM_RETURN(SCM_UNDEFINED);")
 
194
 
 
195
(define-cproc %unregister-finalizer! (ptrobj)
 
196
  "if (!POINTERP(ptrobj)) {
 
197
      Scm_Error(\"<c-ptr> required, but got %S\", ptrobj);
 
198
  }
 
199
  Scm_UnregisterFinalizer(ptrobj);
 
200
  SCM_RETURN(SCM_UNDEFINED);")
 
201
 
 
202
(define-cproc foreign-pointer->c-ptr (ptrClass fptr::<foreign-pointer>)
 
203
  (code "SCM_RETURN(MAKE_POINTER(ptrClass, fptr->ptr));"))
 
204
 
 
205
;;
 
206
;; dlopen, dlsym, dlclose
 
207
;;
 
208
(define-enum RTLD_LAZY)
 
209
(define-enum RTLD_NOW)
 
210
(define-enum RTLD_GLOBAL)
 
211
(define-enum RTLD_LOCAL)
 
212
 
 
213
(define-cproc dlopen (path::<const-cstring> mode::<fixnum>)
 
214
  (code "void *handle = dlopen(path, mode);"
 
215
        "if (handle) {"
 
216
        "    SCM_RETURN(MAKE_VOID_POINTER(handle));"
 
217
        "} else {"
 
218
        "    SCM_RETURN(SCM_FALSE);"
 
219
        "}"))
 
220
 
 
221
(define-cproc dlsym (handle symbol::<const-cstring>)
 
222
  (code "void *ptr = dlsym(POINTER_DATA(handle), symbol);"
 
223
        "if (ptr) {"
 
224
        "    SCM_RETURN(MAKE_VOID_POINTER(ptr));"
 
225
        "} else {"
 
226
        "    SCM_RETURN(SCM_FALSE);"
 
227
        "}"))
 
228
 
 
229
(define-cproc dlsym-default (symbol::<const-cstring>)
 
230
  (code "void *ptr = dlsym(RTLD_DEFAULT, symbol);"
 
231
        "if (ptr) {"
 
232
        "    SCM_RETURN(MAKE_VOID_POINTER(ptr));"
 
233
        "} else {"
 
234
        "    SCM_RETURN(SCM_FALSE);"
 
235
        "}"))
 
236
 
 
237
(define-cproc dlerror ()
 
238
  (code "const char *errmsg = dlerror();"
 
239
        "if (errmsg) {"
 
240
        "    SCM_RETURN(SCM_MAKE_STR_IMMUTABLE(errmsg));"
 
241
        "} else {"
 
242
        "    SCM_RETURN(SCM_FALSE);"
 
243
        "}"))
 
244
 
 
245
(define-cproc dlclose (handle)
 
246
  (code "SCM_RETURN(SCM_MAKE_INT(dlclose(POINTER_DATA(handle))));"))
 
247
 
 
248
;;
 
249
;; others
 
250
;;
 
251
(define-cproc big-endian? ()
 
252
  (code "#ifdef WORDS_BIGENDIAN"
 
253
        "SCM_RETURN(SCM_TRUE);"
 
254
        "#else"
 
255
        "SCM_RETURN(SCM_FALSE);"
 
256
        "#endif"))
 
257
 
 
258
(define-cproc objc-string (ptrClass str::<const-cstring>)
 
259
  (code "#ifdef __OBJC__"
 
260
        "NSString *nsstr = [NSString stringWithCString:str encoding:OBJC_STRING_ENCODING];"
 
261
        "SCM_RETURN(MAKE_POINTER(ptrClass, nsstr));"
 
262
        "#else"
 
263
        "Scm_Error(\"Unsupported operation 'objc-string'\");"
 
264
        "#endif"))
 
265
 
 
266
;; Local variables:
 
267
;; mode: scheme
 
268
;; end: