(define-module (irrlicht util)
- #:use-module (system foreign)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
#:export (bool->integer
- integer->bool
- define-foreign
- define-foreign-record-type
- foreign-record-pointer))
+ integer->bool))
(define (bool->integer var)
(if var 1 0))
(define (integer->bool var)
(if (= var 0) #f #t))
-
-;; Based on guile-sdl2 function, thanks a lot
-(define irrlicht-func
- (let ((cirr (dynamic-link "libCIrrlicht")))
- (lambda (return-type function-name arg-types)
- (pointer->procedure return-type
- (dynamic-func function-name cirr)
- arg-types))))
-
-(define-syntax-rule (define-foreign name return-type func-name arg-types)
- (define-public name
- (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)
- (map (lambda (field-spec)
- (syntax-case field-spec ()
- ((name type getter) #'name)
- ((name type getter setter) #'name)))
- field-specs))
-
- (define (field-types field-specs)
- (map (lambda (field-spec)
- (syntax-case field-spec ()
- ((name type getter) #'type)
- ((name type getter setter) #'type)))
- field-specs))
-
- (define (field-getters field-specs)
- (map (lambda (field-spec field-id)
- (syntax-case field-spec ()
- ((name type getter) (list #'getter field-id))
- ((name type getter setter) (list #'getter field-id))))
- field-specs
- (iota (length field-specs))))
-
- (define (field-setters field-specs)
- (filter-map (lambda (field-spec field-id)
- (syntax-case field-spec ()
- ((name type getter) #f)
- ((name type getter setter) (list #'setter field-id))))
- field-specs
- (iota (length field-specs))))
-
- (syntax-case x ()
- ((_ name (make-name make-arg ...) predicate? 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 (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)))))
-
- (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)))
- (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))
- new-value))
- ...))))))