--- /dev/null
+;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
+;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
+;;;
+;;; This file is part of guile-irrlicht.
+;;;
+;;; Guile-irrlicht is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-irrlicht is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with guile-irrlicht. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+(define-module (irrlicht util foreign)
+ #:use-module (system foreign)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (rnrs bytevectors)
+ #:export (define-foreign
+ define-foreign-record-type
+ foreign-record->pointer))
+
+
+;; Based on guile-sdl2 function, thanks a lot
+(define irrlicht-func
+ (let ((cirr (dynamic-link "libCIrrlicht")))
+ (lambda (return-type function-name arg-types)
+ (pointer->procedure return-type
+ (dynamic-func function-name cirr)
+ arg-types))))
+
+(define-syntax-rule (define-foreign name return-type func-name arg-types)
+ (define-public name
+ (irrlicht-func return-type func-name arg-types)))
+
+
+;; foreign record type
+(define-record-type standard-foreign-record-type
+ (make-foreign-record-type name types fields)
+ foreign-record-type?
+ (name foreign-record-type-name)
+ (types foreign-record-type-types)
+ (fields foreign-record-type-fields))
+
+(define (foreign-record-type-basic-types record-type)
+ (map (lambda (type)
+ (if (foreign-record-type? type)
+ (foreign-record-type-basic-types type)
+ type))
+ (foreign-record-type-types record-type)))
+
+
+;; foreign record
+(define-record-type foreign-record
+ (make-foreign-record type pointer)
+ foreign-record?
+ (type foreign-record-type)
+ (pointer foreign-record-pointer))
+
+(set-record-type-printer! foreign-record
+ (lambda (record port)
+ (let* ((record-type (foreign-record-type record))
+ (name (foreign-record-type-name record-type))
+ (pointer (foreign-record-pointer record))
+ (types (foreign-record-type-types record-type))
+ (fields (foreign-record-type-fields record-type))
+ (values (parse-c-struct pointer types)))
+ (format port "#<~a" name)
+ (for-each (lambda (field value)
+ (format port " ~a: ~a" field value))
+ fields
+ values)
+ (format port ">"))))
+
+(define (foreign-record->pointer record)
+ (foreign-record-pointer record))
+
+
+;; define-foreign-record-type
+(define-syntax define-foreign-record-type
+ (lambda (x)
+ (define (field-names field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name type getter) #'name)
+ ((name type getter setter) #'name)))
+ field-specs))
+
+ (define (field-types field-specs)
+ (map (lambda (field-spec)
+ (syntax-case field-spec ()
+ ((name type getter) #'type)
+ ((name type getter setter) #'type)))
+ field-specs))
+
+ (define (field-getters field-specs)
+ (map (lambda (field-spec field-id)
+ (syntax-case field-spec ()
+ ((name type getter) (list #'getter field-id))
+ ((name type getter setter) (list #'getter field-id))))
+ field-specs
+ (iota (length field-specs))))
+
+ (define (field-setters field-specs)
+ (filter-map (lambda (field-spec field-id)
+ (syntax-case field-spec ()
+ ((name type getter) #f)
+ ((name type getter setter) (list #'setter field-id))))
+ field-specs
+ (iota (length field-specs))))
+
+ (syntax-case x ()
+ ((_ name (make-name make-arg ...) predicate? field-spec ...)
+ (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
+ ((field-name ...) (field-names #'(field-spec ...)))
+ (((getter getter-id) ...) (field-getters #'(field-spec ...)))
+ (((setter setter-id) ...) (field-setters #'(field-spec ...))))
+ #'(begin
+ (define name
+ (make-foreign-record-type 'name (list type-id ...) (list 'field-name ...)))
+
+ (define (make-name make-arg ...)
+ (let ((pointer (make-c-struct (list type-id ...) (list make-arg ...))))
+ (make-foreign-record name pointer)))
+
+ (define (predicate? record)
+ (and (foreign-record? record)
+ (equal? (foreign-record-type-name (foreign-record-type record)) 'name)))
+
+ (define (getter record)
+ (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...))))
+ (list-ref values getter-id)))
+ ...
+
+ (define (setter record new-value)
+ (let* ((types (list type-id ...))
+ (type (list-ref types setter-id))
+ (len (sizeof type))
+ (offset (if (> setter-id 0)
+ (sizeof (list-head types setter-id))
+ 0))
+ (bv (pointer->bytevector (foreign-record-pointer record) len offset 'u32)))
+ (bytevector-set! bv new-value type)
+ new-value))
+ ...))))))
+
+(define (bytevector-set! bv value type)
+ (let ((procedure
+ (cond
+ ((= type int8) bytevector-s8-set!)
+ ((= type int16) bytevector-s16-native-set!)
+ ((= type int32) bytevector-s32-native-set!)
+ ((= type int64) bytevector-s64-native-set!)
+ ((= type uint8) bytevector-u8-set!)
+ ((= type uint16) bytevector-u16-native-set!)
+ ((= type uint32) bytevector-u32-native-set!)
+ ((= type uint64) bytevector-u64-native-set!)
+ ((= type float) bytevector-ieee-single-native-set!)
+ ((= type double) bytevector-ieee-double-native-set!)
+ (else #f))))
+ (if procedure
+ (apply procedure bv 0 value '()))))
projects / guile-irrlicht.git / blobdiff