#: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
(define* (create-device #:key
(device-type 'software)
- (window-size '(640 480))
+ (window-size (make-dimension2d 640 480))
(bits 16)
(fullscreen #f)
(stencilbuffer #f)
('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))))
(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))
(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)
(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 '()))))