From: Javier Sancho Date: Mon, 30 Dec 2019 19:20:03 +0000 (+0100) Subject: Improve foreign records declaration X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=10bdbf4f0184a57c693b3bb6d959d8523a0e8982;p=guile-irrlicht.git Improve foreign records declaration --- diff --git a/irrlicht/device.scm b/irrlicht/device.scm index 25ec8ca..04b3648 100644 --- a/irrlicht/device.scm +++ b/irrlicht/device.scm @@ -23,6 +23,7 @@ #:use-module (system foreign) #:use-module ((irrlicht bindings) #:prefix ffi:) #:use-module ((irrlicht bindings video) #:prefix ffi-video:) + #:use-module (irrlicht dimension2d) #:use-module (irrlicht util) #:export (create-device get-cursor-control @@ -37,7 +38,7 @@ (define* (create-device #:key (device-type 'software) - (window-size '(640 480)) + (window-size (make-dimension2d 640 480)) (bits 16) (fullscreen #f) (stencilbuffer #f) @@ -49,9 +50,10 @@ ('direct3d8 ffi-video:EDT_DIRECT3D8) ('direct3d9 ffi-video:EDT_DIRECT3D9) ('opengl ffi-video:EDT_OPENGL) - ('count ffi-video:EDT_COUNT))) - (wsize (foreign-record-pointer window-size))) - (let ((device (ffi:create-device driver wsize bits + ('count ffi-video:EDT_COUNT)))) + (let ((device (ffi:create-device driver + (dimension2d-pointer window-size) + bits (bool->integer fullscreen) (bool->integer stencilbuffer) (bool->integer vsync)))) diff --git a/irrlicht/dimension2d.scm b/irrlicht/dimension2d.scm index 7eb8cfd..91de9a4 100644 --- a/irrlicht/dimension2d.scm +++ b/irrlicht/dimension2d.scm @@ -24,6 +24,7 @@ #:export (dimension2d make-dimension2d dimension2d? + dimension2d-pointer dimension2d-width dimension2d-height)) @@ -31,5 +32,6 @@ (define-foreign-record-type dimension2d (make-dimension2d width height) dimension2d? + dimension2d-pointer (width uint32 dimension2d-width) (height uint32 dimension2d-height)) diff --git a/irrlicht/util.scm b/irrlicht/util.scm index 9110be9..e7c8641 100644 --- a/irrlicht/util.scm +++ b/irrlicht/util.scm @@ -21,13 +21,11 @@ (define-module (irrlicht util) #: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 (bool->integer integer->bool define-foreign - define-foreign-record-type - foreign-record-pointer)) + define-foreign-record-type)) (define (bool->integer var) (if var 1 0)) @@ -48,33 +46,6 @@ (irrlicht-func return-type func-name arg-types))) ;; foreign struct 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-record-type foreign-record - (make-foreign-record type pointer) - foreign-record? - (type foreign-record-type) - (pointer foreign-record-pointer set-foreign-record-pointer!)) - -(set-record-type-printer! foreign-record - (lambda (record port) - (format port "#<~a" (foreign-record-type-name (foreign-record-type record))) - (let* ((pointer (foreign-record-pointer record)) - (record-type (foreign-record-type record)) - (types (foreign-record-type-types record-type)) - (fields (foreign-record-type-fields record-type)) - (values (parse-c-struct pointer types))) - (for-each (lambda (field value) - (format port " ~a: ~a" field value)) - fields - values)) - (format port ">"))) - (define-syntax define-foreign-record-type (lambda (x) (define (field-names field-specs) @@ -108,44 +79,57 @@ (iota (length field-specs)))) (syntax-case x () - ((_ name (make-name make-arg ...) predicate? field-spec ...) + ((_ name (make-name make-arg ...) predicate? unwrap-record 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-wrapped-pointer-type name + predicate? + wrap-record unwrap-record + (lambda (record port) + (format port "#<~a" 'name) + (let ((values (parse-c-struct (unwrap-record record) (list type-id ...)))) + (for-each (lambda (field value) + (format port " ~a: ~a" field value)) + '(field-name ...) + values)) + (format port ">"))) (define (make-name make-arg ...) - (let* ((types (foreign-record-type-types name)) - (c-struct-pointer (make-c-struct types (list make-arg ...)))) - (make-foreign-record name c-struct-pointer))) - - (define (predicate? record) - (and - (foreign-record? record) - (let* ((record-type (foreign-record-type record)) - (type-name (foreign-record-type-name record-type))) - (equal? type-name (foreign-record-type-name name))))) + (wrap-record (make-c-struct (list type-id ...) (list make-arg ...)))) (define (getter record) - (let* ((pointer (foreign-record-pointer record)) - (record-type (foreign-record-type record)) - (types (foreign-record-type-types record-type)) - (values (parse-c-struct pointer types))) + (let ((values (parse-c-struct (unwrap-record record) (list type-id ...)))) (list-ref values getter-id))) ... (define (setter record new-value) - (let* ((pointer (foreign-record-pointer record)) - (record-type (foreign-record-type record)) - (types (foreign-record-type-types record-type)) - (values (parse-c-struct pointer types))) - (list-set! values setter-id new-value) - (set-foreign-record-pointer! record (make-c-struct types values)) + (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 (unwrap-record 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 '()))))