irrlicht/util/foreign.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 foreign)
  22   #:use-module (system foreign)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-9 gnu)
  26   #:use-module (rnrs bytevectors)
  27   #:export (define-foreign
  28             define-foreign-record-type
  29             foreign-record->pointer))
  30
  31
  32 ;; Based on guile-sdl2 function, thanks a lot
  33 (define irrlicht-func
  34   (let ((cirr (dynamic-link "libCIrrlicht")))
  35     (lambda (return-type function-name arg-types)
  36       (pointer->procedure return-type
  37                           (dynamic-func function-name cirr)
  38                           arg-types))))
  39
  40 (define-syntax-rule (define-foreign name return-type func-name arg-types)
  41   (define-public name
  42     (irrlicht-func return-type func-name arg-types)))
  43
  44
  45 ;; foreign record type
  46 (define-record-type standard-foreign-record-type
  47   (make-foreign-record-type name types fields)
  48   foreign-record-type?
  49   (name foreign-record-type-name)
  50   (types foreign-record-type-types)
  51   (fields foreign-record-type-fields))
  52
  53 (define (foreign-record-type-basic-types record-type)
  54   (map (lambda (type)
  55          (if (foreign-record-type? type)
  56              (foreign-record-type-basic-types type)
  57              type))
  58        (foreign-record-type-types record-type)))
  59
  60
  61 ;; foreign record
  62 (define-record-type foreign-record
  63   (make-foreign-record type pointer)
  64   foreign-record?
  65   (type foreign-record-type)
  66   (pointer foreign-record-pointer))
  67
  68 (set-record-type-printer! foreign-record
  69   (lambda (record port)
  70     (let* ((record-type (foreign-record-type record))
  71            (name (foreign-record-type-name record-type))
  72            (pointer (foreign-record-pointer record))
  73            (types (foreign-record-type-types record-type))
  74            (fields (foreign-record-type-fields record-type))
  75            (values (parse-c-struct pointer types)))
  76       (format port "#<~a" name)
  77       (for-each (lambda (field value)
  78                   (format port " ~a: ~a" field value))
  79                 fields
  80                 values)
  81       (format port ">"))))
  82
  83 (define (foreign-record->pointer record)
  84   (foreign-record-pointer record))
  85
  86
  87 ;; define-foreign-record-type
  88 (define-syntax define-foreign-record-type
  89   (lambda (x)
  90     (define (field-names field-specs)
  91       (map (lambda (field-spec)
  92              (syntax-case field-spec ()
  93                ((name type getter) #'name)
  94                ((name type getter setter) #'name)))
  95            field-specs))
  96
  97     (define (field-types field-specs)
  98       (map (lambda (field-spec)
  99              (syntax-case field-spec ()
 100                ((name type getter) #'type)
 101                ((name type getter setter) #'type)))
 102            field-specs))
 103
 104     (define (field-getters field-specs)
 105       (map (lambda (field-spec field-id)
 106              (syntax-case field-spec ()
 107                ((name type getter) (list #'getter field-id))
 108                ((name type getter setter) (list #'getter field-id))))
 109            field-specs
 110            (iota (length field-specs))))
 111
 112     (define (field-setters field-specs)
 113       (filter-map (lambda (field-spec field-id)
 114                     (syntax-case field-spec ()
 115                       ((name type getter) #f)
 116                       ((name type getter setter) (list #'setter field-id))))
 117                   field-specs
 118                   (iota (length field-specs))))
 119
 120     (syntax-case x ()
 121       ((_ name (make-name make-arg ...) predicate? field-spec ...)
 122        (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
 123                      ((field-name ...) (field-names #'(field-spec ...)))
 124                      (((getter getter-id) ...) (field-getters #'(field-spec ...)))
 125                      (((setter setter-id) ...) (field-setters #'(field-spec ...))))
 126          #'(begin
 127              (define name
 128                (make-foreign-record-type 'name (list type-id ...) (list 'field-name ...)))
 129
 130              (define (make-name make-arg ...)
 131                (let ((pointer (make-c-struct (list type-id ...) (list make-arg ...))))
 132                  (make-foreign-record name pointer)))
 133
 134              (define (predicate? record)
 135                (and (foreign-record? record)
 136                     (equal? (foreign-record-type-name (foreign-record-type record)) 'name)))
 137
 138              (define (getter record)
 139                (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...))))
 140                  (list-ref values getter-id)))
 141              ...
 142
 143              (define (setter record new-value)
 144                (let* ((types (list type-id ...))
 145                       (type (list-ref types setter-id))
 146                       (len (sizeof type))
 147                       (offset (if (> setter-id 0)
 148                                   (sizeof (list-head types setter-id))
 149                                   0))
 150                       (bv (pointer->bytevector (foreign-record-pointer record) len offset 'u32)))
 151                  (bytevector-set! bv new-value type)
 152                  new-value))
 153              ...))))))
 154
 155 (define (bytevector-set! bv value type)
 156   (let ((procedure
 157          (cond
 158            ((= type int8) bytevector-s8-set!)
 159            ((= type int16) bytevector-s16-native-set!)
 160            ((= type int32) bytevector-s32-native-set!)
 161            ((= type int64) bytevector-s64-native-set!)
 162            ((= type uint8) bytevector-u8-set!)
 163            ((= type uint16) bytevector-u16-native-set!)
 164            ((= type uint32) bytevector-u32-native-set!)
 165            ((= type uint64) bytevector-u64-native-set!)
 166            ((= type float) bytevector-ieee-single-native-set!)
 167            ((= type double) bytevector-ieee-double-native-set!)
 168            (else #f))))
 169     (if procedure
 170         (apply procedure bv 0 value '()))))