X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=irrlicht%2Futil%2Fforeign.scm;h=1c54e12d2c6cb2b747a751331d31587f354fe659;hb=0db087e68fdb778a73beca6cf0d35d4e718339e5;hp=8c9a9ad5467a1815a34aa558fe36674d4e3ab974;hpb=0d8955b4f8a481aec28acc91ba964ff66c918e75;p=guile-irrlicht.git 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))