-;;; 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
- bit-field
- bit-field-group
- get-bit-field-group-type
- make-c-bit-field-group
- parse-c-bit-field-group
- sizeof+
- make-c-struct+
- parse-c-struct+))
-
-
-;; 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 '()))))
-
-
-;; bit fields
-(define-record-type bit-field-record
- (bit-field type bits)
- bit-field?
- (type bit-field-type)
- (bits bit-field-bits))
-
-(define-record-type bit-field-group-subtype-record
- (make-bit-field-group-subtype type arity maker parser)
- bit-field-group-subtype?
- (type bit-field-group-subtype-type)
- (arity bit-field-group-subtype-arity)
- (maker bit-field-group-subtype-maker)
- (parser bit-field-group-subtype-parser))
-
-(define-record-type bit-field-group-record
- (make-bit-field-group subtypes)
- bit-field-group?
- (subtypes bit-field-group-subtypes))
-
-(define (build-bit-field-group-subtype-maker bit-fields)
- "Return a maker procedure for the bit field group"
- (lambda (values)
- (let loop ((fields bit-fields)
- (vals values)
- (res '())
- (bits 0))
- (cond ((null? fields)
- (apply logior res))
- (else
- (loop (cdr fields)
- (cdr vals)
- (cons (ash (car vals) bits) res)
- (+ bits (bit-field-bits (car fields)))))))))
-
-(define (build-bit-field-group-subtype-parser bit-fields)
- (lambda (value)
- (let loop ((fields bit-fields)
- (res '())
- (bits 0))
- (cond ((null? fields)
- res)
- (else
- (let ((n-bits (+ bits (bit-field-bits (car fields)))))
- (loop (cdr fields)
- (append res (list (bit-extract value bits n-bits)))
- n-bits)))))))
-
-(define (validate-bit-field-group bit-fields)
- "Return a list with the calculated real types of the bit field group or error if overflow"
- (let loop ((fields bit-fields)
- (current-type 0)
- (n-bits 0)
- (subtypes '())
- (subtype-fields '()))
- (cond ((null? fields)
- (if (> current-type 0)
- ;; Append last type processed to the result
- (append subtypes
- (list (make-bit-field-group-subtype
- current-type
- (length subtype-fields)
- (build-bit-field-group-subtype-maker subtype-fields)
- (build-bit-field-group-subtype-parser subtype-fields))))
- ;; We already have the result
- subtypes))
- (else
- (let* ((field (car fields))
- (type (max (bit-field-type field) current-type))
- (bits (+ (bit-field-bits field) n-bits)))
- (cond ((> bits (* (sizeof type) 8))
- ;; Bits overflow
- (if (> n-bits 0)
- ;; Make a new subtype and continue
- (loop fields 0 0
- (append subtypes
- (list (make-bit-field-group-subtype
- current-type
- (length subtype-fields)
- (build-bit-field-group-subtype-maker subtype-fields)
- (build-bit-field-group-subtype-parser subtype-fields))))
- '())
- ;; Bits exceed type capacity
- (error "Bit field group overflow")))
- (else
- (loop (cdr fields) type bits subtypes
- (append subtype-fields (list field))))))))))
-
-(define-syntax-rule (bit-field-group (type bits) ...)
- (let* ((bit-fields (list (bit-field type bits) ...))
- (subtypes (validate-bit-field-group bit-fields)))
- (make-bit-field-group subtypes)))
-
-(define (get-bit-field-group-type group)
- (map (lambda (subtype)
- (bit-field-group-subtype-type subtype))
- (bit-field-group-subtypes group)))
-
-(define (make-c-bit-field-group group values)
- (let make-c ((subtypes (bit-field-group-subtypes group))
- (vals values))
- (cond ((null? subtypes)
- '())
- (else
- (let* ((subtype (car subtypes))
- (arity (bit-field-group-subtype-arity subtype))
- (maker (bit-field-group-subtype-maker subtype)))
- (cons (maker (list-head vals arity))
- (make-c (cdr subtypes) (list-tail vals arity))))))))
-
-(define (parse-c-bit-field-group values group)
- (apply append
- (map (lambda (subtype value)
- ((bit-field-group-subtype-parser subtype) value))
- (bit-field-group-subtypes group)
- values)))
-
-(define (convert-struct types)
- "Convert a struct type with bit fields in an ordinary struct type"
- (cond ((null? types)
- '())
- (else
- (let ((type (car types)))
- (cond ((list? type)
- (cons (convert-struct type)
- (convert-struct (cdr types))))
- ((bit-field-group? type)
- (append (get-bit-field-group-type type)
- (convert-struct (cdr types))))
- (else
- (cons type
- (convert-struct (cdr types)))))))))
-
-(define (convert-struct-values types vals)
- "Convert struct values with bit fields in an ordinary struct"
- (cond ((null? types)
- '())
- (else
- (let ((type (car types))
- (val (car vals)))
- (cond ((list? type)
- (cons (convert-struct-values type val)
- (convert-struct-values (cdr types) (cdr vals))))
- ((bit-field-group? type)
- (append (make-c-bit-field-group type val)
- (convert-struct-values (cdr types) (cdr vals))))
- (else
- (cons val
- (convert-struct-values (cdr types) (cdr vals)))))))))
-
-(define (parse-struct-values vals types)
- "Parse struct values with bit fields from an ordinary struct"
- (cond ((null? types)
- '())
- (else
- (let ((type (car types))
- (val (car vals)))
- (cond ((list? type)
- (cons (parse-struct-values val type)
- (parse-struct-values (cdr vals) (cdr types))))
- ((bit-field-group? type)
- (let ((arity (length (bit-field-group-subtypes type))))
- (cons (parse-c-bit-field-group (list-head vals arity) type)
- (parse-struct-values (list-tail vals arity) (cdr types)))))
- (else
- (cons val
- (parse-struct-values (cdr vals) (cdr types)))))))))
-
-(define (sizeof+ type)
- (if (list? type)
- (sizeof (convert-struct type))
- (sizeof type)))
-
-(define (make-c-struct+ types vals)
- (make-c-struct (convert-struct types)
- (convert-struct-values types vals)))
-
-(define (parse-c-struct+ foreign types)
- (parse-struct-values
- (parse-c-struct foreign (convert-struct types))
- types))