-
Notifications
You must be signed in to change notification settings - Fork 1
/
raylib-macros.scm
145 lines (139 loc) · 5.58 KB
/
raylib-macros.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
;;; Macros to define foreign functions
; Converts signatures like
; ((c-pointer (struct StructType)) structName) to "*structName"
; Converts signatures like
; (int name) or ((c-pointer void) name) to "name"
(define-for-syntax (get-argument signature)
(let ((name (symbol->string (cadr signature))))
(if (and (list? (car signature))
(list? (cadar signature)))
(string-append "*" name)
name)))
; Creates foreign-lambda for C function with struct arguments passed by value.
; Arguments:
; - name of C function (string);
; - return type in standard Chicken FFI format;
; - argument list in standard Chicken FFI format.
(define-syntax foreign-lambda-with-struct
(er-macro-transformer
(lambda (exp rename compare)
(let* ((args (drop exp 3))
(foreign-function-name (list-ref exp 1))
(return-type (list-ref exp 2))
(c-names (map get-argument (car args)))
(c-names (string-join c-names ", "))
(c-function (string-join (list foreign-function-name "(" c-names ")") ""))
(c-call (if (eq? return-type 'void)
(string-join (list c-function ";") "")
(string-join (list "C_return(" c-function ");") ""))))
`(foreign-lambda* ,return-type ,@args
,c-call)))))
; Creates named Scheme function for C function with struct arguments passed by value.
; Arguments:
; - Scheme function name
; - name of C function (string);
; - return type in standard Chicken FFI format;
; - argument list in standard Chicken FFI format.
(define-syntax foreign-define-with-struct
(er-macro-transformer
(lambda (exp rename compare)
(let* ((to-lambda (drop exp 2))
(args (drop exp 4))
(function-name (list-ref exp 1))
(names (map cadr (car args))))
`(define (,function-name ,@names)
((foreign-lambda-with-struct ,@to-lambda)
,@names))))))
; Creates boolean Scheme function (predicate) for C function returning 0 for false and
; something else for true.
; Arguments:
; - Scheme function name
; - name of C function (string);
; - return type in standard Chicken FFI format;
; - argument list in standard Chicken FFI format.
(define-syntax foreign-predicate
(er-macro-transformer
(lambda (exp rename compare)
(let* ((to-lambda (drop exp 2))
(args (drop exp 4))
(function-name (list-ref exp 1))
(names (map cadr (car args))))
`(define (,function-name ,@names)
(not (= ((foreign-lambda-with-struct ,@to-lambda)
,@names)
0)))))))
; Creates foreign-lambda* that creates newly allocated C structure
; Arguments:
; - Scheme function name
; - name of C function (string);
; - return type in Scheme format;
; - return type in standard Chicken FFI format;
; - list of arguments in standard Chicken FFI format.
(define-syntax foreign-constructor
(er-macro-transformer
(lambda (exp rename compare)
(let* ((rest (drop exp 5))
(args (if (eq? rest '())
'()
(car rest)))
(function-name (list-ref exp 1))
(foreign-function-name (list-ref exp 2))
(return-type (list-ref exp 3))
(c-type (symbol->string (cadadr (list-ref exp 4))))
(names (map cadr args))
(c-names (map get-argument args))
(c-names (string-join c-names ", "))
(c-function (string-join (list foreign-function-name "(" c-names ")") ""))
(allocation-code
(format #f
"~a* new_object = (~a*)malloc(sizeof(~a));
*new_object = ~a;
C_return(new_object);"
c-type
c-type
c-type
c-function)))
`(define (,function-name ,@names)
(let ((new-object
((foreign-lambda* ,return-type ,args
,allocation-code)
,@names)))
(set-finalizer! new-object free)
new-object))))))
; Creates foreign-lambda* that allocates C structure
; and fills its fields with given values.
; Argumens:
; - Scheme function name
; - return type in Scheme format;
; - string with C type of structure;
; - list of fields in standard Chicken FFI format
(define-syntax foreign-constructor*
(er-macro-transformer
(lambda (exp rename compare)
(let* ((args (car (drop exp 4)))
(function-name (list-ref exp 1))
(return-type (list-ref exp 2))
(c-type (list-ref exp 3))
(names (map cadr args))
(c-names (map get-argument args))
(init-field (lambda (field)
(format #f
"new_object->~a = ~a;"
(string-delete #\* field)
field)))
(init-strings (map init-field c-names))
(allocation-code (format #f
"~a* new_object = (~a*)malloc(sizeof(~a));
~a
C_return(new_object);"
c-type
c-type
c-type
(string-join init-strings ""))))
`(define (,function-name ,@names)
(let ((new-object
((foreign-lambda* ,return-type ,args
,allocation-code)
,@names)))
(set-finalizer! new-object free)
new-object))))))