#: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
(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))
projects / guile-irrlicht.git / blobdiff