sdl3/internal/utilities.scm

(import (scheme)
        (chicken base)
        (chicken bitwise)
        (chicken syntax)
        (srfi 152))

(define (snake-upcase in)
  (string-map (lambda (c)
                (if (char=? #\- c)
                    #\_
                    (char-upcase c)))
              in))

(define-syntax define-sdl-const-values
  (er-macro-transformer
   (lambda (exp rename compare)
     (let ((prefix (cadr exp))
           (type (caddr exp))
           (enum-labels (cdddr exp)))
       `(begin
          ,@(map (lambda (enum-label)
                   (let ((full-str (string-append (symbol->string prefix)
                                                  "-" (symbol->string enum-label))))
                     `(begin
                        (export ,(string->symbol full-str))
                        (define ,(string->symbol full-str)
                          (foreign-value
                           ,(string-append "SDL_" (snake-upcase full-str))
                           ,type)))))
                 enum-labels))))))

(define (foldl-uint-flags flags)
  (foldl bitwise-ior (car flags) (cdr flags)))

(define-syntax call-c*
  (er-macro-transformer
   (lambda (exp rename compare)
     (let ((return-type (list-ref exp 1))
           (proc (list-ref exp 2))
           (args (list-ref exp 3))
           (callbody (list-ref exp 4))
           (callbody-args (list-ref exp 5)))
       `((foreign-lambda* ,return-type
             ,args
           ,(apply format #f callbody
                   (symbol->string proc)
                   (map (compose symbol->string cadr) args)
                   callbody-args))
         ,@(map cadr args))))))

(define-syntax call-c
  (syntax-rules (void)

    ((_ void proc (args ...))
     (call-c* void proc (args ...)
              "~A(~{~^, ~};" ()))
    ((_ return-type proc (args ...))
     (call-c* return-type proc (args ...)
              "C_return(~A(~{~^, ~}));"))))