From: Javier Sancho <jsf@jsancho.org>
Date: Sun, 2 Feb 2020 17:32:30 +0000 (+0100)
Subject: Bit fields support
X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=0db087e68fdb778a73beca6cf0d35d4e718339e5;p=guile-irrlicht.git

Bit fields support
---

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..397b4a7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+*.log
diff --git a/irrlicht/util/foreign.scm b/irrlicht/util/foreign.scm
index 8c9a9ad..1c54e12 100644
--- a/irrlicht/util/foreign.scm
+++ b/irrlicht/util/foreign.scm
@@ -26,7 +26,15 @@
   #:use-module (rnrs bytevectors)
   #:export (define-foreign
             define-foreign-record-type
-            foreign-record->pointer))
+            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
@@ -168,3 +176,186 @@
            (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))
diff --git a/tests/foreign-bit-fields.scm b/tests/foreign-bit-fields.scm
new file mode 100644
index 0000000..581bea2
--- /dev/null
+++ b/tests/foreign-bit-fields.scm
@@ -0,0 +1,51 @@
+;;; 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/>.
+
+
+(use-modules (system foreign)
+             (srfi srfi-64)
+             (irrlicht util foreign))
+
+(test-begin "foreign-bit-fields")
+
+;; Simple bit field group
+(define bfg (bit-field-group (int8 2) (int8 3) (int8 1)))
+(test-equal (get-bit-field-group-type bfg)
+            (list int8))
+(test-equal (make-c-bit-field-group bfg '(1 1 1))
+            '(#b100101))
+(test-equal (parse-c-bit-field-group '(#b110011) bfg)
+            '(3 4 1))
+
+;; Large bit field group
+(define bfg (bit-field-group (int8 2) (int8 3) (int8 5)))
+(test-equal (get-bit-field-group-type bfg)
+            (list int8 int8))
+(test-equal (make-c-bit-field-group bfg '(1 1 2))
+            '(#b101 #b10))
+(test-equal (parse-c-bit-field-group '(#b10011 #b10) bfg)
+            '(3 4 2))
+
+;; Structs with bit fields
+(define types (list int8 (bit-field-group (int8 2) (int8 3) (int8 2))))
+(test-equal (sizeof+ types) 2)
+(define values '(10 (2 4 3)))
+(test-equal (parse-c-struct+ (make-c-struct+ types values) types) values)
+
+(test-end "foreign-bit-fields")