source: project/release/3/pyffi/trunk/pyffi-support.scm @ 11622

Last change on this file since 11622 was 11622, checked in by Ivan Raikov, 12 years ago

Using utf8-srfi-13

File size: 11.8 KB
Line 
1;;
2;; Python-Scheme FFI. Based on pyffi.lisp by Dmitri Hrapof.
3;; Adapted to Chicken Scheme by Ivan Raikov.
4;;
5;;
6;; This program is free software: you can redistribute it and/or
7;; modify it under the terms of the GNU General Public License as
8;; published by the Free Software Foundation, either version 3 of the
9;; License, or (at your option) any later version.
10;;
11;; This program is distributed in the hope that it will be useful, but
12;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;; General Public License for more details.
15;;
16;; A full copy of the GPL license can be found at
17;; <http://www.gnu.org/licenses/>.
18;;
19
20(define-extension pyffi)
21
22(require-extension lolevel)
23(require-extension extras)
24(require-extension srfi-1)
25(require-extension srfi-4)
26(require-extension utf8)
27(require-extension utf8-lolevel)
28(require-extension utf8-srfi-13)
29
30
31(declare
32 (not usual-integrations)
33 (inline)
34 (lambda-lift)
35 (export  py-start py-stop py-import py-eval py-apply
36          raise-python-exception 
37          *py-functions*
38          PyObject_GetAttrString PyObject_SetAttrString 
39          PyObject_CallObject PyCallable_Check Py_DecRef))
40
41
42(define (pyffi:error x . rest)
43  (let ((port (open-output-string)))
44    (if (port? x)
45        (begin
46          (display "[" port)
47          (display (port-name x) port)
48          (display "] " port)))
49    (let loop ((objs (if (port? x) rest (cons x rest))))
50      (if (null? objs)
51          (begin
52            (newline port)
53            (error 'pyffi (get-output-string port)))
54          (begin (display (car objs) port)
55                 (display " " port)
56                 (loop (cdr objs)))))))
57
58(define (alist? x)  (and (list? x) (every pair? x)))
59
60(define-record pytype name to from)
61
62(define-macro (define-pytype name to from)
63  `(define ,name (make-pytype ',name ,to ,from)))
64
65(define-macro (translate-to-foreign x typ)
66  `((pytype-to ,typ) ,x))
67
68(define-macro (translate-from-foreign x typ)
69  `((pytype-from ,typ) ,x))
70
71;; Scheme -> Python
72(define (py-object-to value)
73  (cond
74   ((integer? value)  (translate-to-foreign value py-int))
75   ((real? value)     (translate-to-foreign value py-float))
76   ((alist? value)    (translate-to-foreign value py-dict))
77   ((list? value)     (if (eq? 'ascii (car value)) 
78                          (translate-to-foreign (cadr value) py-ascii)
79                          (translate-to-foreign value py-list)))
80   ((string? value)   (translate-to-foreign value py-unicode))
81   ((vector? value)   (translate-to-foreign value py-tuple))
82   ((pointer? value)  value)
83   ((boolean? value)  (translate-to-foreign value py-bool))
84   (else (pyffi:error 'py-object-to "invalid value " value))))
85
86;; Python -> Scheme
87(define (py-object-from value)
88  (if (not value) (raise-python-exception))
89  (let ((typ-name   (PyObject_Type_asString value)))
90    (let ((typ-key (alist-ref typ-name *python-types* string=?)))
91      (if typ-key
92          (translate-from-foreign value typ-key)
93          (begin
94            (Py_IncRef value)
95            value)))))
96
97;; Embed, but do not parse
98#>
99
100#include <Python.h>
101
102
103#if ((PY_MAJOR_VERSION == 2) && (PY_MINOR_VERSION <= 3))
104void Py_IncRef (PyObject *x)
105{
106  Py_INCREF(x);
107}
108
109void Py_DecRef (PyObject *x)
110{
111  Py_DECREF(x);
112}
113#endif
114PyObject *pyffi_PyImport_ImportModuleEx (char *, PyObject *, PyObject *, PyObject *);
115
116
117PyObject *pyffi_PyRun_String (const char *str, int s, PyObject *g, PyObject *l)
118{
119   return PyRun_String (str, s, g, l);
120}
121
122
123PyObject *pyffi_PyImport_ImportModuleEx (char *name, PyObject *g, PyObject *l, PyObject *fl)
124{
125   return PyImport_ImportModuleEx (name,g,l,fl);
126}
127
128
129#ifndef Py_UNICODE_WIDE
130 int *pyffi_PyUnicode_AsUnicode (PyObject *x)
131 {
132    return PyUnicodeUCS2_AsUnicode (x);
133 }
134 PyObject *pyffi_PyUnicode_FromUnicode (const int *s, int n)
135 {
136    return PyUnicodeUCS2_FromUnicode (s, n);
137 } 
138 int pyffi_PyUnicode_GetSize (PyObject *x)
139 {
140    return PyUnicodeUCS2_GetSize (x);
141 }
142#else
143 int *pyffi_PyUnicode_AsUnicode (PyObject *x)
144 {
145    int * result;
146    result = PyUnicodeUCS4_AsUnicode (x);
147   
148    return result;
149 }
150 PyObject *pyffi_PyUnicode_FromUnicode (const int *s, int n)
151 {
152    return PyUnicodeUCS4_FromUnicode (s, n);
153 } 
154 int pyffi_PyUnicode_GetSize (PyObject *x)
155 {
156    return PyUnicodeUCS4_GetSize (x);
157 }
158#endif
159
160C_word PyBool_asBool(PyObject *x)
161{
162   if (x == (Py_True)) return C_SCHEME_TRUE;
163   return C_SCHEME_FALSE;
164}
165
166int pyffi_PyUnicode_ref (int *x, int i)
167{
168   int result;
169
170   if (i >= 0) 
171     result = x[i];
172   else
173     result = 0;
174   
175   return result;
176}
177
178<#
179
180
181(define PyBool-AsBool (foreign-lambda scheme-object "PyBool_asBool" nonnull-c-pointer))
182(define pyffi_PyUnicode_ref (foreign-lambda integer "pyffi_PyUnicode_ref" nonnull-c-pointer integer))
183
184;; Parse & embed
185#>!
186
187___declare(type, "pyobject;(c-pointer \"PyObject\");py-object-to;py-object-from")
188
189<#
190
191;; Parse but do not embed
192#>?
193void Py_Initialize (void);
194void Py_Finalize (void);
195
196void Py_IncRef (PyObject *);
197void Py_DecRef (PyObject *);
198
199int PyCallable_Check (PyObject *);
200PyObject *PyErr_Occurred (void);
201void PyErr_Clear (void);
202
203PyObject *PyDict_New (void);
204pyobject PyDict_Keys (PyObject *);
205int PyDict_Size  (PyObject *);
206pyobject PyDict_GetItem (PyObject *, pyobject);
207pyobject PyDict_GetItemString (PyObject *, const char *);
208pyobject PyDict_Items (PyObject *);
209int PyDict_SetItem (PyObject *, pyobject, pyobject);
210
211double PyFloat_AsDouble (PyObject *);
212PyObject *PyFloat_FromDouble (double);
213
214pyobject PyImport_GetModuleDict (void);
215PyObject *PyImport_Import (pyobject );
216
217PyObject *PyImport_ImportModule (const char *name);
218PyObject *PyImport_AddModule (const char *name);
219
220
221long PyInt_AsLong (PyObject *);
222PyObject *PyInt_FromLong (long);
223
224PyObject *PyList_New (int);
225int PyList_Size (PyObject *);
226pyobject PyList_GetItem (PyObject *, int);
227int PyList_SetItem (PyObject *, int, pyobject);
228
229pyobject PyModule_GetDict (PyObject *);
230pyobject PyObject_CallObject (PyObject *, pyobject);
231
232pyobject PyObject_GetAttrString (PyObject *, const char *);
233int PyObject_SetAttrString (PyObject *, const char *, pyobject);
234pyobject PyObject_Str (PyObject *);
235
236
237char *PyString_AsString (PyObject *);
238PyObject *PyString_FromString (const char *);
239
240PyObject *PyTuple_New (int);
241int PyTuple_Size (PyObject *);
242pyobject PyTuple_GetItem (PyObject *, int);
243int PyTuple_SetItem (PyObject *, int, pyobject);
244
245
246PyObject *PyBool_FromLong(long);
247
248<#
249
250
251;; Parse & embed
252#>!
253
254PyObject *pyffi_PyImport_ImportModuleEx (char *, PyObject *, PyObject *, PyObject *);
255
256pyobject pyffi_PyRun_String (const char *str, int s, PyObject *g, PyObject *l);
257
258int *pyffi_PyUnicode_AsUnicode (PyObject *);
259PyObject *pyffi_PyUnicode_FromUnicode (const int *, int);
260int pyffi_PyUnicode_GetSize (PyObject *);
261
262
263PyObject *PyModule_GetDict_asPtr (PyObject *x)
264{
265 return PyModule_GetDict (x);
266}
267
268char *PyString_asString(pyobject op) 
269{
270 printf ("PyString_AsString\n");
271  return (((PyStringObject *)(op))->ob_sval);
272}
273
274char *PyObject_Type_asString (pyobject x)
275{
276  PyObject *typ, *str;
277
278  typ = PyObject_Type (x);
279  str = PyObject_Str (typ);
280
281  Py_DecRef (typ);
282
283  return (((PyStringObject *)(str))->ob_sval);
284}
285
286char *PyErr_Occurred_asString (void)
287{
288  PyObject *exc, *str;
289
290  exc = PyErr_Occurred ();
291  str = PyObject_Str (exc);
292
293  Py_DecRef (exc);
294
295  return (((PyStringObject *)(str))->ob_sval);
296}
297<#
298
299
300(define (pyerror-exn x) (make-property-condition 'pyerror 'message x))
301
302(define (raise-python-exception)
303  (let* ((desc   (PyErr_Occurred_asString)))
304    (PyErr_Clear)
305    (print-error-message desc)
306    (signal (pyerror-exn desc))))
307
308(define-pytype py-int PyInt_FromLong PyInt_AsLong)
309
310(define-pytype py-tuple
311  (lambda (value)
312    (let* ((len (vector-length value))
313           (tup (PyTuple_New len)))
314       (if (not tup) (raise-python-exception))
315       (let loop ((i 0))
316         (if (< i len) 
317             (begin
318               (if (not (zero? (PyTuple_SetItem tup i (vector-ref value i))))
319                   (raise-python-exception))
320               (loop (+ 1 i)))
321             tup))))
322  (lambda (value)
323    (let* ((len (PyTuple_Size value))
324           (tup (make-vector len)))
325      (let loop ((i 0))
326        (if (< i len) 
327            (begin
328              (vector-set! tup i (PyTuple_GetItem value i))
329              (loop (+ 1 i)))
330            tup)))))
331
332
333(define-pytype py-list
334  (lambda (value)
335    (let* ((len (length value))
336           (lst (PyList_New len)))
337       (if (not lst) (raise-python-exception))
338       (let loop ((i 0))
339         (if (< i len)
340             (begin
341               (if (not (zero? (PyList_SetItem lst i (list-ref value i))))
342                   (raise-python-exception))
343               (loop (+ i 1)))
344             lst))))
345  (lambda (value)
346    (let ((len (PyList_Size value)))
347      (let loop ((i 0) (lst (list)))
348        (if (< i len)
349            (let ((item (PyList_GetItem value i)))
350              (loop (+ 1 i) (cons item lst)))
351            (begin
352              (reverse lst)))))))
353
354
355(define-pytype py-bool
356  (lambda (x) (PyBool_FromLong (if x 1 0)))
357  PyBool-AsBool)
358
359(define-pytype py-float PyFloat_FromDouble PyFloat_AsDouble)
360
361(define (utf8-string->py-unicode value)
362  ;; Given a Scheme UTF8 string, converts it into Python Unicode string
363  (let ((str (list->s32vector (map char->integer (utf8-string->list value)))))
364    (pyffi_PyUnicode_FromUnicode str (s32vector-length str))))
365
366(define (py-unicode->utf8-string value)
367  ;; Given a Python Unicode string, converts it into Scheme UTF8 string
368  (let ((buf (pyffi_PyUnicode_AsUnicode value))
369        (len (pyffi_PyUnicode_GetSize value)))
370    (let loop ((i 0) (lst (list)))
371      (if (< i len)
372          (loop (fx+ 1 i) (cons (pyffi_PyUnicode_ref buf i) lst))
373          (list->string (map integer->char (reverse lst)))))))
374
375(define-pytype py-ascii PyString_FromString PyString_AsString)
376(define-pytype py-unicode utf8-string->py-unicode py-unicode->utf8-string)
377
378(define-pytype py-dict 
379  ;; Given a Scheme alist, converts it into a Python dictionary
380  (lambda (value)
381    (let ((dct (PyDict_New)))
382      (if (not dct) (raise-python-exception))
383      (for-each (lambda (kv) 
384                  (match kv 
385                         (( k v ) (if (not (zero? (PyDict_SetItem dct k v)))
386                                      (raise-python-exception)))
387                         (else (pyffi:error 'py-dict "invalid alist pair " kv))))
388                value)))
389  ;; Given a Python dictionary, converts it into a Scheme alist
390  (lambda (value)
391    (let ((its (PyDict_Items value)))
392      (let loop ((its its) (alst (list)))
393          (if (null? its) alst
394              (let ((item (car its)))
395                (let ((k (vector-ref item 0))
396                      (v (vector-ref item 1)))
397                  (loop (cdr its) (cons (cons k v) alst)))))))))
398
399(define-pytype py-instance 
400  identity
401  ;; Given a Python class instance, converts it into a Scheme alist
402  (lambda (value) (PyObject_GetAttrString value "__dict__")))
403
404
405(define  *python-types*
406  `(("<type 'bool'>"      . ,py-bool)
407    ("<type 'int'>"       . ,py-int)
408    ("<type 'float'>"     . ,py-float)
409    ("<type 'list'>"      . ,py-list)
410    ("<type 'str'>"       . ,py-ascii)
411    ("<type 'unicode'>"   . ,py-unicode)
412    ("<type 'dict'>"      . ,py-dict)
413    ("<type 'instance'>"  . ,py-instance)
414    ("<type 'tuple'>"     . ,py-tuple)))
415
416
417(define-constant +py-file-input+    257)
418(define-constant +py-single-input+  256)
419(define-constant +py-eval-input+    258)
420
421(define  *py-main-module* #f)
422(define  *py-main-module-dict* #f)
423(define  *py-functions* (list))
424
425(define (py-start)
426  (Py_Initialize)
427  (set! *py-main-module* (PyImport_AddModule "__main__"))
428  (set! *py-main-module-dict* (PyModule_GetDict_asPtr *py-main-module*))
429  (let ((tmp (pyffi_PyRun_String "from __builtin__ import *" +py-single-input+ 
430                           *py-main-module-dict* (null-pointer))))
431    (Py_DecRef tmp)))
432
433(define (py-stop)
434  (set! *py-main-module* #f)
435  (set! *py-main-module-dict* #f)
436  (set! *py-functions* (list))
437  (Py_Finalize))
438
439(define (py-import name)
440  (let ((p (string-index name #\.)))
441    (let ((m (pyffi_PyImport_ImportModuleEx 
442              name *py-main-module-dict* *py-main-module-dict* (null-pointer))))
443      (if m
444          (if (= -1 (PyObject_SetAttrString 
445                     *py-main-module* (if p (string-drop name p) name) m))
446              (begin
447                (Py_DecRef m)
448                (raise-python-exception))
449              (Py_DecRef m))
450          (raise-python-exception)))))
451
452
453(define (py-eval expr)
454  (pyffi_PyRun_String expr +py-eval-input+ *py-main-module-dict* *py-main-module-dict*))
455
456(define (py-apply func . rest)
457  (PyObject_CallObject func (list->vector rest)))
Note: See TracBrowser for help on using the repository browser.