X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=irrlicht%2Futil.scm;h=8c5b9e4eb4651465c38ffda5b64d101a8623c4e6;hb=8994b42fea213a741631efbe7fd9c09c0aab7100;hp=efa5ba7fbe2c7547fa7f0cf217b459cd73259d5d;hpb=71e6e638cba09643fca5dccd1b7295b7db0def06;p=guile-irrlicht.git

diff --git a/irrlicht/util.scm b/irrlicht/util.scm
index efa5ba7..8c5b9e4 100644
--- a/irrlicht/util.scm
+++ b/irrlicht/util.scm
@@ -19,121 +19,11 @@
 
 
 (define-module (irrlicht util)
-  #:use-module (system foreign)
-  #:use-module (srfi srfi-1)
-  #:use-module (rnrs bytevectors)
   #: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-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-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 ...)
-               (wrap-record (make-c-struct (list type-id ...) (list make-arg ...))))
-
-             (define (getter record)
-               (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
-                 (list-ref values getter-id)))
-             ...
-
-             (define (setter record new-value)
-               (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 '()))))
-
-(define (foreign-record->pointer record)
-  (struct-ref record 0))