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             bit-field
  31             bit-field-group
  32             get-bit-field-group-type
  33             make-c-bit-field-group
  34             parse-c-bit-field-group
  35             sizeof+
  36             make-c-struct+
  37             parse-c-struct+))
  38
  39
  40 ;; Based on guile-sdl2 function, thanks a lot
  41 (define irrlicht-func
  42   (let ((cirr (dynamic-link "libCIrrlicht")))
  43     (lambda (return-type function-name arg-types)
  44       (pointer->procedure return-type
  45                           (dynamic-func function-name cirr)
  46                           arg-types))))
  47
  48 (define-syntax-rule (define-foreign name return-type func-name arg-types)
  49   (define-public name
  50     (irrlicht-func return-type func-name arg-types)))
  51
  52
  53 ;; foreign record type
  54 (define-record-type standard-foreign-record-type
  55   (make-foreign-record-type name types fields)
  56   foreign-record-type?
  57   (name foreign-record-type-name)
  58   (types foreign-record-type-types)
  59   (fields foreign-record-type-fields))
  60
  61 (define (foreign-record-type-basic-types record-type)
  62   (map (lambda (type)
  63          (if (foreign-record-type? type)
  64              (foreign-record-type-basic-types type)
  65              type))
  66        (foreign-record-type-types record-type)))
  67
  68
  69 ;; foreign record
  70 (define-record-type foreign-record
  71   (make-foreign-record type pointer)
  72   foreign-record?
  73   (type foreign-record-type)
  74   (pointer foreign-record-pointer))
  75
  76 (set-record-type-printer! foreign-record
  77   (lambda (record port)
  78     (let* ((record-type (foreign-record-type record))
  79            (name (foreign-record-type-name record-type))
  80            (pointer (foreign-record-pointer record))
  81            (types (foreign-record-type-types record-type))
  82            (fields (foreign-record-type-fields record-type))
  83            (values (parse-c-struct pointer types)))
  84       (format port "#<~a" name)
  85       (for-each (lambda (field value)
  86                   (format port " ~a: ~a" field value))
  87                 fields
  88                 values)
  89       (format port ">"))))
  90
  91 (define (foreign-record->pointer record)
  92   (foreign-record-pointer record))
  93
  94
  95 ;; define-foreign-record-type
  96 (define-syntax define-foreign-record-type
  97   (lambda (x)
  98     (define (field-names field-specs)
  99       (map (lambda (field-spec)
 100              (syntax-case field-spec ()
 101                ((name type getter) #'name)
 102                ((name type getter setter) #'name)))
 103            field-specs))
 104
 105     (define (field-types field-specs)
 106       (map (lambda (field-spec)
 107              (syntax-case field-spec ()
 108                ((name type getter) #'type)
 109                ((name type getter setter) #'type)))
 110            field-specs))
 111
 112     (define (field-getters field-specs)
 113       (map (lambda (field-spec field-id)
 114              (syntax-case field-spec ()
 115                ((name type getter) (list #'getter field-id))
 116                ((name type getter setter) (list #'getter field-id))))
 117            field-specs
 118            (iota (length field-specs))))
 119
 120     (define (field-setters field-specs)
 121       (filter-map (lambda (field-spec field-id)
 122                     (syntax-case field-spec ()
 123                       ((name type getter) #f)
 124                       ((name type getter setter) (list #'setter field-id))))
 125                   field-specs
 126                   (iota (length field-specs))))
 127
 128     (syntax-case x ()
 129       ((_ name (make-name make-arg ...) predicate? field-spec ...)
 130        (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
 131                      ((field-name ...) (field-names #'(field-spec ...)))
 132                      (((getter getter-id) ...) (field-getters #'(field-spec ...)))
 133                      (((setter setter-id) ...) (field-setters #'(field-spec ...))))
 134          #'(begin
 135              (define name
 136                (make-foreign-record-type 'name (list type-id ...) (list 'field-name ...)))
 137
 138              (define (make-name make-arg ...)
 139                (let ((pointer (make-c-struct (list type-id ...) (list make-arg ...))))
 140                  (make-foreign-record name pointer)))
 141
 142              (define (predicate? record)
 143                (and (foreign-record? record)
 144                     (equal? (foreign-record-type-name (foreign-record-type record)) 'name)))
 145
 146              (define (getter record)
 147                (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...))))
 148                  (list-ref values getter-id)))
 149              ...
 150
 151              (define (setter record new-value)
 152                (let* ((types (list type-id ...))
 153                       (type (list-ref types setter-id))
 154                       (len (sizeof type))
 155                       (offset (if (> setter-id 0)
 156                                   (sizeof (list-head types setter-id))
 157                                   0))
 158                       (bv (pointer->bytevector (foreign-record-pointer record) len offset 'u32)))
 159                  (bytevector-set! bv new-value type)
 160                  new-value))
 161              ...))))))
 162
 163 (define (bytevector-set! bv value type)
 164   (let ((procedure
 165          (cond
 166            ((= type int8) bytevector-s8-set!)
 167            ((= type int16) bytevector-s16-native-set!)
 168            ((= type int32) bytevector-s32-native-set!)
 169            ((= type int64) bytevector-s64-native-set!)
 170            ((= type uint8) bytevector-u8-set!)
 171            ((= type uint16) bytevector-u16-native-set!)
 172            ((= type uint32) bytevector-u32-native-set!)
 173            ((= type uint64) bytevector-u64-native-set!)
 174            ((= type float) bytevector-ieee-single-native-set!)
 175            ((= type double) bytevector-ieee-double-native-set!)
 176            (else #f))))
 177     (if procedure
 178         (apply procedure bv 0 value '()))))
 179
 180
 181 ;; bit fields
 182 (define-record-type bit-field-record
 183   (bit-field type bits)
 184   bit-field?
 185   (type bit-field-type)
 186   (bits bit-field-bits))
 187
 188 (define-record-type bit-field-group-subtype-record
 189   (make-bit-field-group-subtype type arity maker parser)
 190   bit-field-group-subtype?
 191   (type bit-field-group-subtype-type)
 192   (arity bit-field-group-subtype-arity)
 193   (maker bit-field-group-subtype-maker)
 194   (parser bit-field-group-subtype-parser))
 195
 196 (define-record-type bit-field-group-record
 197   (make-bit-field-group subtypes)
 198   bit-field-group?
 199   (subtypes bit-field-group-subtypes))
 200
 201 (define (build-bit-field-group-subtype-maker bit-fields)
 202   "Return a maker procedure for the bit field group"
 203   (lambda (values)
 204     (let loop ((fields bit-fields)
 205                (vals values)
 206                (res '())
 207                (bits 0))
 208       (cond ((null? fields)
 209              (apply logior res))
 210             (else
 211              (loop (cdr fields)
 212                    (cdr vals)
 213                    (cons (ash (car vals) bits) res)
 214                    (+ bits (bit-field-bits (car fields)))))))))
 215
 216 (define (build-bit-field-group-subtype-parser bit-fields)
 217   (lambda (value)
 218     (let loop ((fields bit-fields)
 219                (res '())
 220                (bits 0))
 221       (cond ((null? fields)
 222              res)
 223             (else
 224              (let ((n-bits (+ bits (bit-field-bits (car fields)))))
 225                (loop (cdr fields)
 226                      (append res (list (bit-extract value bits n-bits)))
 227                      n-bits)))))))
 228
 229 (define (validate-bit-field-group bit-fields)
 230   "Return a list with the calculated real types of the bit field group or error if overflow"
 231   (let loop ((fields bit-fields)
 232              (current-type 0)
 233              (n-bits 0)
 234              (subtypes '())
 235              (subtype-fields '()))
 236     (cond ((null? fields)
 237            (if (> current-type 0)
 238                ;; Append last type processed to the result
 239                (append subtypes
 240                        (list (make-bit-field-group-subtype
 241                               current-type
 242                               (length subtype-fields)
 243                               (build-bit-field-group-subtype-maker subtype-fields)
 244                               (build-bit-field-group-subtype-parser subtype-fields))))
 245                ;; We already have the result
 246                subtypes))
 247           (else
 248            (let* ((field (car fields))
 249                   (type (max (bit-field-type field) current-type))
 250                   (bits (+ (bit-field-bits field) n-bits)))
 251              (cond ((> bits (* (sizeof type) 8))
 252                     ;; Bits overflow
 253                     (if (> n-bits 0)
 254                         ;; Make a new subtype and continue
 255                         (loop fields 0 0
 256                               (append subtypes
 257                                       (list (make-bit-field-group-subtype
 258                                              current-type
 259                                              (length subtype-fields)
 260                                              (build-bit-field-group-subtype-maker subtype-fields)
 261                                              (build-bit-field-group-subtype-parser subtype-fields))))
 262                               '())
 263                         ;; Bits exceed type capacity
 264                         (error "Bit field group overflow")))
 265                    (else
 266                     (loop (cdr fields) type bits subtypes
 267                           (append subtype-fields (list field))))))))))
 268
 269 (define-syntax-rule (bit-field-group (type bits) ...)
 270   (let* ((bit-fields (list (bit-field type bits) ...))
 271          (subtypes (validate-bit-field-group bit-fields)))
 272     (make-bit-field-group subtypes)))
 273
 274 (define (get-bit-field-group-type group)
 275   (map (lambda (subtype)
 276          (bit-field-group-subtype-type subtype))
 277        (bit-field-group-subtypes group)))
 278
 279 (define (make-c-bit-field-group group values)
 280   (let make-c ((subtypes (bit-field-group-subtypes group))
 281                (vals values))
 282     (cond ((null? subtypes)
 283            '())
 284           (else
 285            (let* ((subtype (car subtypes))
 286                   (arity (bit-field-group-subtype-arity subtype))
 287                   (maker (bit-field-group-subtype-maker subtype)))
 288              (cons (maker (list-head vals arity))
 289                    (make-c (cdr subtypes) (list-tail vals arity))))))))
 290
 291 (define (parse-c-bit-field-group values group)
 292   (apply append
 293          (map (lambda (subtype value)
 294                 ((bit-field-group-subtype-parser subtype) value))
 295               (bit-field-group-subtypes group)
 296               values)))
 297
 298 (define (convert-struct types)
 299   "Convert a struct type with bit fields in an ordinary struct type"
 300   (cond ((null? types)
 301          '())
 302         (else
 303          (let ((type (car types)))
 304            (cond ((list? type)
 305                   (cons (convert-struct type)
 306                         (convert-struct (cdr types))))
 307                  ((bit-field-group? type)
 308                   (append (get-bit-field-group-type type)
 309                           (convert-struct (cdr types))))
 310                  (else
 311                   (cons type
 312                         (convert-struct (cdr types)))))))))
 313
 314 (define (convert-struct-values types vals)
 315   "Convert struct values with bit fields in an ordinary struct"
 316   (cond ((null? types)
 317          '())
 318         (else
 319          (let ((type (car types))
 320                (val (car vals)))
 321            (cond ((list? type)
 322                   (cons (convert-struct-values type val)
 323                         (convert-struct-values (cdr types) (cdr vals))))
 324                  ((bit-field-group? type)
 325                   (append (make-c-bit-field-group type val)
 326                           (convert-struct-values (cdr types) (cdr vals))))
 327                  (else
 328                   (cons val
 329                         (convert-struct-values (cdr types) (cdr vals)))))))))
 330
 331 (define (parse-struct-values vals types)
 332   "Parse struct values with bit fields from an ordinary struct"
 333   (cond ((null? types)
 334          '())
 335         (else
 336          (let ((type (car types))
 337                (val (car vals)))
 338            (cond ((list? type)
 339                   (cons (parse-struct-values val type)
 340                         (parse-struct-values (cdr vals) (cdr types))))
 341                  ((bit-field-group? type)
 342                   (let ((arity (length (bit-field-group-subtypes type))))
 343                     (cons (parse-c-bit-field-group (list-head vals arity) type)
 344                           (parse-struct-values (list-tail vals arity) (cdr types)))))
 345                  (else
 346                   (cons val
 347                         (parse-struct-values (cdr vals) (cdr types)))))))))
 348
 349 (define (sizeof+ type)
 350   (if (list? type)
 351       (sizeof (convert-struct type))
 352       (sizeof type)))
 353
 354 (define (make-c-struct+ types vals)
 355   (make-c-struct (convert-struct types)
 356                  (convert-struct-values types vals)))
 357
 358 (define (parse-c-struct+ foreign types)
 359   (parse-struct-values
 360    (parse-c-struct foreign (convert-struct types))
 361    types))