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 (srfi srfi-9)
  25   #:use-module (srfi srfi-9 gnu)
  26   #:export (bool->integer
  27             integer->bool
  28             define-foreign
  29             define-foreign-record-type))
  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-record-type standard-foreign-record-type
  51   (make-foreign-record-type name types fields)
  52   foreign-record-type?
  53   (name foreign-record-type-name)
  54   (types foreign-record-type-types)
  55   (fields foreign-record-type-fields))
  56
  57 (define-record-type foreign-record
  58   (make-foreign-record type pointer)
  59   foreign-record?
  60   (type foreign-record-type)
  61   (pointer foreign-record-pointer set-foreign-record-pointer!))
  62
  63 (set-record-type-printer! foreign-record
  64   (lambda (record port)
  65     (format port "#<~a" (foreign-record-type-name (foreign-record-type record)))
  66     (let* ((pointer (foreign-record-pointer record))
  67            (record-type (foreign-record-type record))
  68            (types (foreign-record-type-types record-type))
  69            (fields (foreign-record-type-fields record-type))
  70            (values (parse-c-struct pointer types)))
  71       (for-each (lambda (field value)
  72                   (format port " ~a: ~a" field value))
  73                 fields
  74                 values))
  75     (format port ">")))
  76
  77 (define-syntax define-foreign-record-type
  78   (lambda (x)
  79     (define (field-names field-specs)
  80       (map (lambda (field-spec)
  81              (syntax-case field-spec ()
  82                ((name type getter) #'name)
  83                ((name type getter setter) #'name)))
  84            field-specs))
  85
  86     (define (field-types field-specs)
  87       (map (lambda (field-spec)
  88              (syntax-case field-spec ()
  89                ((name type getter) #'type)
  90                ((name type getter setter) #'type)))
  91            field-specs))
  92
  93     (define (field-getters field-specs)
  94       (map (lambda (field-spec field-id)
  95              (syntax-case field-spec ()
  96                ((name type getter) (list #'getter field-id))
  97                ((name type getter setter) (list #'getter field-id))))
  98            field-specs
  99            (iota (length field-specs))))
 100
 101     (define (field-setters field-specs)
 102       (filter-map (lambda (field-spec field-id)
 103                     (syntax-case field-spec ()
 104                       ((name type getter) #f)
 105                       ((name type getter setter) (list #'setter field-id))))
 106                   field-specs
 107                   (iota (length field-specs))))
 108
 109     (syntax-case x ()
 110       ((_ name (make-name make-arg ...) predicate? field-spec ...)
 111        (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
 112                      ((field-name ...) (field-names #'(field-spec ...)))
 113                      (((getter getter-id) ...) (field-getters #'(field-spec ...)))
 114                      (((setter setter-id) ...) (field-setters #'(field-spec ...))))
 115          #'(begin
 116              (define name
 117                (make-foreign-record-type
 118                 'name
 119                 (list type-id ...)
 120                 (list 'field-name ...)))
 121
 122              (define (make-name make-arg ...)
 123                (let* ((types (foreign-record-type-types name))
 124                       (c-struct-pointer (make-c-struct types (list make-arg ...))))
 125                  (make-foreign-record name c-struct-pointer)))
 126
 127              (define (predicate? record)
 128                (and
 129                 (foreign-record? record)
 130                 (let* ((record-type (foreign-record-type record))
 131                        (type-name (foreign-record-type-name record-type)))
 132                   (equal? type-name (foreign-record-type-name name)))))
 133
 134              (define (getter record)
 135                (let* ((pointer (foreign-record-pointer record))
 136                       (record-type (foreign-record-type record))
 137                       (types (foreign-record-type-types record-type))
 138                       (values (parse-c-struct pointer types)))
 139                  (list-ref values getter-id)))
 140              ...
 141
 142              (define (setter record new-value)
 143                (let* ((pointer (foreign-record-pointer record))
 144                       (record-type (foreign-record-type record))
 145                       (types (foreign-record-type-types record-type))
 146                       (values (parse-c-struct pointer types)))
 147                  (list-set! values setter-id new-value)
 148                  (set-foreign-record-pointer! record (make-c-struct types values))
 149                  new-value))
 150              ...
 151
 152              (export name)
 153              (export make-name)
 154              (export predicate?)
 155              (export getter)
 156              ...
 157              (export setter)
 158              ...))))))