source: project/release/4/xlib/xlib.scm @ 13305

Last change on this file since 13305 was 13305, checked in by felix winkelmann, 11 years ago

ported to chicken 4

File size: 2.8 KB
Line 
1;;;; xlib.scm
2
3
4(declare
5  (no-bound-checks)
6  (no-procedure-checks)
7  (disable-interrupts) )
8
9
10#>
11#include "xlib-c.c"
12
13#define C_free_xptr(p)          (XFree((void *)C_block_item(p, 0)), C_SCHEME_UNDEFINED)
14#define C_fetch_c_strlen(b)     C_fix(strlen((char *)C_block_item(b, 0)))
15#define C_peek_c_string(b, to, len) (C_memcpy(C_data_pointer(to), (char *)C_block_item(b, 0), C_unfix(len)), C_SCHEME_UNDEFINED)
16<#
17
18
19(module xlib ()
20  (import scheme chicken foreign srfi-13 data-structures)
21  (begin-for-syntax (require-library matchable))
22  (import-for-syntax matchable chicken)
23
24(define-for-syntax (xlate-type t cn)
25  (match (strip-syntax t)               ; punt
26    [('POINTER 'FUNCTION) (xlate-warn t 'c-pointer cn)]
27    [('POINTER (or 'STRUCT 'UNION 'VOID)) 'c-pointer]
28    [('POINTER (? string? s)) `(c-pointer ,s)]
29    [('POINTER t) `(c-pointer ,(xlate-type t cn))]
30    ['POINTER 'c-pointer]
31    [(or 'CHAR 'SIGNED-CHAR) 'char]
32    [(or 'UNSIGNED-CHAR 'UNSIGNED-SHORT 'UNSIGNED-LONG 'FLOAT 'DOUBLE)
33     (string->symbol (string-downcase (->string t))) ]
34    [(or 'SHORT 'SIGNED-SHORT) 'short]
35    [(or 'LONG 'SIGNED-LONG) 'long]
36    [(or 'UNSIGNED-INT 'UNSIGNED) 'unsigned-integer]
37    ['INT 'integer] 
38    [_ (syntax-error "type not supported" t cn)] ) )
39
40(define-for-syntax (xlate-warn t t2 cn)
41  (cond-expand
42   [pickytypes (fprintf (current-error-port) "Warning: ~s type in ~s.~%" t cn)]
43   [else] )
44  t2)
45
46(define-for-syntax (xlate-rtype t cn)
47  (match t
48    ['VOID 'void]
49    [(or 'xstring* 'c-string) t]
50    ['STRING (xlate-warn t 'c-string cn)]
51    [_ (xlate-type t cn)] ) )
52
53(define-for-syntax (xlate-atype t cn)
54  (match t
55    [(or 'c-string 'STRING) 'c-string]
56    [_ (xlate-type t cn)] ) )
57
58(define peek-and-free-c-string
59  (lambda (b)
60    (and (not (##sys#null-pointer? b))
61         (let* ([len (##core#inline "C_fetch_c_strlen" b)]
62                [str2 (##sys#make-string len)] )
63           (##core#inline "C_peek_c_string" b str2 len)
64           (##core#inline "C_free_xptr" b)
65           str2) ) ) )
66
67(define-foreign-type xstring* c-pointer
68  #f
69  peek-and-free-c-string)
70
71(eval-when (compile)
72  (print "Compiling xlib (this may take a while) ..."))
73
74(define-syntax (foreign-function x r c)
75  (match (cdr x)
76    ((name args result cname)
77     `(,(r 'begin)
78       (,(r 'export) ,name)
79       (,(r 'define) ,name
80        (,(r 'foreign-lambda)
81         ,(xlate-rtype result cname)
82         ,cname
83         ,@(map (cut xlate-atype <> cname) args)) ) ))))
84
85(define-syntax (foreign-cb-function x r c)
86  (match (cdr x)
87    ((name args result cname)
88     `(,(r 'begin)
89       (,(r 'export) ,name)
90       (,(r 'define) ,name
91        (,(r 'foreign-safe-lambda)
92         ,(xlate-rtype result cname)
93         ,cname 
94         ,@(map (cut xlate-atype <> cname) args)) ) ) ) ))
95
96(define-syntax foreign-define
97  (syntax-rules ()
98    ((_ name val) 
99     (begin
100       (export name)
101       (define name val)))))
102
103(include "xlib-original.scm")
104
105)
Note: See TracBrowser for help on using the repository browser.