From 0db087e68fdb778a73beca6cf0d35d4e718339e5 Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Sun, 2 Feb 2020 18:32:30 +0100 Subject: [PATCH] Bit fields support --- .gitignore | 1 + irrlicht/util/foreign.scm | 193 ++++++++++++++++++++++++++++++++++- tests/foreign-bit-fields.scm | 51 +++++++++ 3 files changed, 244 insertions(+), 1 deletion(-) create mode 100644 .gitignore create mode 100644 tests/foreign-bit-fields.scm 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 +;;; +;;; 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 +;;; . + + +(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") -- 2.39.5