blob: bdc69424cc89ffd2cce00522ae3845e647830576 (
plain)
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
|
;;; guile-sdl3 -- Scheme bindings for SDL3
;;; Copyright © 2024 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
;;; Commentary:
;;
;; Low-level FFI binding utilities.
;;
;;; Code:
(define-module (sdl3 bindings utils)
#:use-module (ice-9 match)
#:use-module (sdl3 config)
#:use-module (sdl3 guardian)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (system foreign)
#:use-module (system foreign-library)
#:export (bool
define-enum
define-bitmask
define-sdl
define-sdl-pointer-type
define-symbol<->enum
flags->bitmask))
;; Type aliases:
(define bool uint8)
(define-syntax enum-case
(syntax-rules ()
((_ x) (error "no matching enum" x))
((_ x (var val) . rest)
(if (eq? x var) val (enum-case x . rest)))))
(define-syntax define-enum
(lambda (stx)
(syntax-case stx ()
((_ type-name atom->enum enum->atom (atom name . id) ...)
(every identifier? #'(name ...))
(with-syntax (((defs ...)
(let lp ((i 0) (specs #'((name . id) ...)))
(syntax-case specs ()
(() '())
(((name) . rest)
(cons #`(define name #,i)
(lp (1+ i) #'rest)))
(((name id) . rest)
(cons #`(define name id)
(lp (1+ (syntax->datum #'id)) #'rest)))))))
#'(begin
(define type-name int)
defs ...
(define (atom->enum x)
(match x ('atom name) ...))
(define (enum->atom x)
(enum-case x (name 'atom) ...))))))))
(define-syntax bitmask-case
(syntax-rules ()
((_ x) (error "no matching flag" x))
((_ x (var val) . rest)
(let ((cont (lambda () (bitmask-case x . rest))))
(if (zero? (logand x var))
(cont)
(cons val (cont)))))))
(define-syntax define-bitmask
(lambda (stx)
(syntax-case stx ()
((_ (type-name c-type)
symbols->bitmask
bitmask->symbols
(sym name) ...)
(every identifier? #'(name ...))
(with-syntax (((defs ...)
(let lp ((i 1) (names #'(name ...)))
(syntax-case names ()
(() '())
((name . rest)
(cons #`(define name #,i)
(lp (ash i 1) #'rest)))))))
#'(begin
(define type-name c-type)
defs ...
(define (symbols->bitmask flags)
(fold (lambda (flag result)
(logior (match flag ('sym name) ...)
result))
0 flags))
(define (bitmask->symbols x)
(bitmask-case x (name 'sym) ...))))))))
(define-syntax define-sdl
(lambda (stx)
(syntax-case stx (->)
((_ name arg-type ... -> return-type)
#`(define name
(foreign-library-function %libsdl3
#,(symbol->string (syntax->datum #'name))
#:arg-types (list arg-type ...)
#:return-type return-type)))
((_ name arg-type ...)
#'(define-sdl name arg-type ... -> void)))))
(define-syntax-rule (define-sdl-pointer-type name
pred wrap unwrap
destroyed-pred set-destroyed
print
(field accessors ...) ...)
(begin
(define-record-type name
(ctor ptr)
pred
(ptr unwrap)
(destroyed? destroyed-pred set-destroyed)
(field accessors ...) ...)
(define (wrap ptr)
(sdl-protect (ctor ptr)))
(set-record-type-printer! name print)))
|
