First commit!main

1 files changed, 133 insertions, 0 deletions

diff --git a/sdl3/bindings/utils.scm b/sdl3/bindings/utils.scm
new file mode 100644
index 0000000..bdc6942
--- /dev/null
+++ b/sdl3/bindings/utils.scm
@@ -0,0 +1,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)))