irrlicht/util.scm

   1 ;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
   2 ;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
   3 ;;;
   4 ;;; This file is part of guile-irrlicht.
   5 ;;;
   6 ;;; Guile-irrlicht is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation; either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; Guile-irrlicht is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with guile-irrlicht.  If not, see
  18 ;;; <http://www.gnu.org/licenses/>.
  19
  20
  21 (define-module (irrlicht util)
  22   #:use-module (system foreign)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (rnrs bytevectors)
  25   #:export (bool->integer
  26             integer->bool
  27             define-foreign
  28             define-foreign-record-type
  29             foreign-record->pointer))
  30
  31 (define (bool->integer var)
  32   (if var 1 0))
  33
  34 (define (integer->bool var)
  35   (if (= var 0) #f #t))
  36
  37 ;; Based on guile-sdl2 function, thanks a lot
  38 (define irrlicht-func
  39   (let ((cirr (dynamic-link "libCIrrlicht")))
  40     (lambda (return-type function-name arg-types)
  41       (pointer->procedure return-type
  42                           (dynamic-func function-name cirr)
  43                           arg-types))))
  44
  45 (define-syntax-rule (define-foreign name return-type func-name arg-types)
  46   (define-public name
  47     (irrlicht-func return-type func-name arg-types)))
  48
  49 ;; foreign struct record type
  50 (define-syntax define-foreign-record-type
  51   (lambda (x)
  52     (define (field-names field-specs)
  53       (map (lambda (field-spec)
  54              (syntax-case field-spec ()
  55                ((name type getter) #'name)
  56                ((name type getter setter) #'name)))
  57            field-specs))
  58
  59     (define (field-types field-specs)
  60       (map (lambda (field-spec)
  61              (syntax-case field-spec ()
  62                ((name type getter) #'type)
  63                ((name type getter setter) #'type)))
  64            field-specs))
  65
  66     (define (field-getters field-specs)
  67       (map (lambda (field-spec field-id)
  68              (syntax-case field-spec ()
  69                ((name type getter) (list #'getter field-id))
  70                ((name type getter setter) (list #'getter field-id))))
  71            field-specs
  72            (iota (length field-specs))))
  73
  74     (define (field-setters field-specs)
  75       (filter-map (lambda (field-spec field-id)
  76                     (syntax-case field-spec ()
  77                       ((name type getter) #f)
  78                       ((name type getter setter) (list #'setter field-id))))
  79                   field-specs
  80                   (iota (length field-specs))))
  81
  82     (syntax-case x ()
  83       ((_ name (make-name make-arg ...) predicate? field-spec ...)
  84        (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
  85                      ((field-name ...) (field-names #'(field-spec ...)))
  86                      (((getter getter-id) ...) (field-getters #'(field-spec ...)))
  87                      (((setter setter-id) ...) (field-setters #'(field-spec ...))))
  88          #'(begin
  89              (define-wrapped-pointer-type name
  90                predicate?
  91                wrap-record unwrap-record
  92                (lambda (record port)
  93                  (format port "#<~a" 'name)
  94                  (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
  95                    (for-each (lambda (field value)
  96                                (format port " ~a: ~a" field value))
  97                              '(field-name ...)
  98                              values))
  99                  (format port ">")))
 100
 101              (define (make-name make-arg ...)
 102                (wrap-record (make-c-struct (list type-id ...) (list make-arg ...))))
 103
 104              (define (getter record)
 105                (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
 106                  (list-ref values getter-id)))
 107              ...
 108
 109              (define (setter record new-value)
 110                (let* ((types (list type-id ...))
 111                       (type (list-ref types setter-id))
 112                       (len (sizeof type))
 113                       (offset (if (> setter-id 0)
 114                                   (sizeof (list-head types setter-id))
 115                                   0))
 116                       (bv (pointer->bytevector (unwrap-record record) len offset 'u32)))
 117                  (bytevector-set! bv new-value type)
 118                  new-value))
 119              ...))))))
 120
 121 (define (bytevector-set! bv value type)
 122   (let ((procedure
 123          (cond
 124            ((= type int8) bytevector-s8-set!)
 125            ((= type int16) bytevector-s16-native-set!)
 126            ((= type int32) bytevector-s32-native-set!)
 127            ((= type int64) bytevector-s64-native-set!)
 128            ((= type uint8) bytevector-u8-set!)
 129            ((= type uint16) bytevector-u16-native-set!)
 130            ((= type uint32) bytevector-u32-native-set!)
 131            ((= type uint64) bytevector-u64-native-set!)
 132            ((= type float) bytevector-ieee-single-native-set!)
 133            ((= type double) bytevector-ieee-double-native-set!)
 134            (else #f))))
 135     (if procedure
 136         (apply procedure bv 0 value '()))))
 137
 138 (define (foreign-record->pointer record)
 139   (struct-ref record 0))