Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added C array utils and tests

This commit is contained in:
retropikzel 2025-04-06 17:11:31 +03:00
parent d5ad504f3a
commit 3834161c67
13 changed files with 315 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
README.md
View File

@ -35,7 +35,9 @@ conforming to some specification.
- [Chibi](#compiling-the-library-chibi) - [Chibi](#compiling-the-library-chibi)
- [Gauche](#compiling-the-library-gauche) - [Gauche](#compiling-the-library-gauche)
- [Dependencies](#dependencies) - [Dependencies](#dependencies)
- [Chibi](#dependencies-chibi)
- [Chicken](#dependencies-chicken) - [Chicken](#dependencies-chicken)
- [Gauche](#dependencies-gauche)
- [Racket](#dependencies-racket) - [Racket](#dependencies-racket)
- [Kawa](#dependencies-kawa) - [Kawa](#dependencies-kawa)
- [Reference](#reference) - [Reference](#reference)
@ -202,12 +204,16 @@ to ./snow/retropikzel/pffi and run command corresponding to your implementation.
#### Dependencies <a name="dependencies"></a> #### Dependencies <a name="dependencies"></a>
The library depends on (libffi)[https://sourceware.org/libffi/) and Some implementations have extra dependencies/requirements beyond just the
some implementations have extra dependencies/requiremetns beyond that. library.
#### Chibi <a name="dependencies-chibi"></a>
Building depends on libffi.
Debian/Ubuntu/Mint install with: Debian/Ubuntu/Mint install with:
apt install libffi8 libffi-dev apt install libffi-dev
#### Chicken <a name="dependencies-chicken"></a> #### Chicken <a name="dependencies-chicken"></a>
@ -215,6 +221,14 @@ Needs [r7rs egg](https://wiki.call-cc.org/eggref/5/r7rs), install with:
chicken-install r7rs chicken-install r7rs
#### Gauche <a name="dependencies-gauche"></a>
Building depends on libffi.
Debian/Ubuntu/Mint install with:
apt install libffi-dev
#### Racket <a name="dependencies-racket"></a> #### Racket <a name="dependencies-racket"></a>
Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs), install with: Needs [racket-r7rs](https://github.com/lexi-lambda/racket-r7rs), install with:

13
retropikzel/pffi.sld
View File

@ -125,7 +125,10 @@
(scheme char) (scheme char)
(scheme file) (scheme file)
(scheme process-context) (scheme process-context)
(stklos))) (stklos))
(export make-external-function
calculate-struct-size-and-offsets
struct-make))
(tr7 (tr7
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
@ -157,11 +160,17 @@
pffi-pointer-get pffi-pointer-get
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-define-struct
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-struct-dereference
pffi-array?
pffi-array-allocate
pffi-pointer->array
pffi-array-get
pffi-array-set!
pffi-list->array pffi-list->array
pffi-array->list pffi-array->list
pffi-define pffi-define

2
retropikzel/pffi/kawa.scm
View File

@ -197,7 +197,7 @@
(integer->char r) (integer->char r)
r)))) r))))
(define pffi-struct-dereference #;(define pffi-struct-dereference
(lambda (struct) (lambda (struct)
;; WIP ;; WIP
(pffi-struct-pointer struct) (pffi-struct-pointer struct)

2
retropikzel/pffi/mosh.scm
View File

@ -156,6 +156,6 @@
(map pffi-type->native-type argument-types) (map pffi-type->native-type argument-types)
procedure))))) procedure)))))
(define pffi-struct-dereference #;(define pffi-struct-dereference
(lambda (struct) (lambda (struct)
(pffi-struct-pointer struct))) (pffi-struct-pointer struct)))

2
retropikzel/pffi/racket.scm
View File

@ -115,6 +115,6 @@
(integer->char r) (integer->char r)
r)))) r))))
(define pffi-struct-dereference #;(define pffi-struct-dereference
(lambda (struct) (lambda (struct)
(pffi-struct-pointer struct))) (pffi-struct-pointer struct)))

3
retropikzel/pffi/sagittarius.scm
View File

@ -22,8 +22,7 @@
((equal? type 'string) 'void*) ((equal? type 'string) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'callback) ((equal? type 'callback) 'callback)
((equal? type 'struct) 'void*) ((and (pair? type) (equal? 'struct (car type))) 'void*)
((list? type) (map pffi-type->native-type type))
(else #f)))) (else #f))))
(define pffi-pointer? (define pffi-pointer?

50
retropikzel/pffi/shared/array.scm
View File

@ -1,22 +1,58 @@
(define-record-type <pffi-array>
(array-make type size pointer)
pffi-array?
(type pffi-array-type)
(size pffi-array-size)
(pointer pffi-array-pointer))
(define pffi-list->array (define pffi-list->array
(lambda (type list-arg) (lambda (type list-arg)
(let* ((type-size (pffi-size-of type)) (let* ((array-size (length list-arg))
(array (pffi-pointer-allocate (* type-size (length list-arg)))) (type-size (pffi-size-of type))
(array (pffi-pointer-allocate (* type-size array-size)))
(offset 0)) (offset 0))
(for-each (for-each
(lambda (item) (lambda (item)
(pffi-pointer-set! array type offset item) (pffi-pointer-set! array type offset item)
(set! offset (+ offset type-size))) (set! offset (+ offset type-size)))
list-arg) list-arg)
array))) (array-make type array-size array))))
(define pffi-pointer->array
(lambda (pointer type size)
(array-make type size pointer)))
(define pffi-array->list (define pffi-array->list
(lambda (type array size) (lambda (array)
(letrec* ((type-size (pffi-size-of type)) (letrec* ((type (pffi-array-type array))
(max-offset (* type-size size)) (type-size (pffi-size-of type))
(max-offset (* type-size (pffi-array-size array)))
(array-pointer (pffi-array-pointer array))
(looper (lambda (offset result) (looper (lambda (offset result)
(if (= offset max-offset) (if (= offset max-offset)
result result
(looper (+ offset type-size) (looper (+ offset type-size)
(append result (list (pffi-pointer-get array type offset)))))))) (append result
(list (pffi-pointer-get array-pointer
type
offset))))))))
(looper 0 (list))))) (looper 0 (list)))))
(define pffi-array-allocate
(lambda (type size)
(array-make type size (pffi-pointer-allocate-calloc size (pffi-size-of type)))))
(define pffi-array-get
(lambda (array index)
(let ((type (pffi-array-type array)))
(pffi-pointer-get (pffi-array-pointer array)
type
(* (pffi-size-of type) index)))))
(define pffi-array-set!
(lambda (array index value)
(let ((type (pffi-array-type array)))
(pffi-pointer-set! (pffi-array-pointer array)
type
(* (pffi-size-of type) index)
value))))

10
retropikzel/pffi/shared/main.scm
View File

@ -1,5 +1,6 @@
(cond-expand (cond-expand
((or chicken-5 chicken-6) (mosh (define pffi-init (lambda () #t)))
(chicken
(define-syntax pffi-init (define-syntax pffi-init
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
@ -7,6 +8,12 @@
(chicken memory)) (chicken memory))
#t)))) #t))))
(gambit #t) (gambit #t)
(ypsilon
(define-syntax pffi-init
(syntax-rules ()
((_)
(import (ypsilon ffi)
(ypsilon c-types))))))
(else (define pffi-init (lambda () #t)))) (else (define pffi-init (lambda () #t))))
(define pffi-type? (define pffi-type?
@ -18,7 +25,6 @@
(define pffi-size-of (define pffi-size-of
(lambda (object) (lambda (object)
(cond ((pffi-struct? object) (pffi-struct-size object)) (cond ((pffi-struct? object) (pffi-struct-size object))
;((pffi-union? object) (pffi-union-size object))
((pffi-type? object) (size-of-type object)) ((pffi-type? object) (size-of-type object))
(else (error "Not pffi-struct, pffi-enum of pffi-type" object))))) (else (error "Not pffi-struct, pffi-enum of pffi-type" object)))))

11
retropikzel/pffi/shared/pointer.scm
View File

@ -1,5 +1,4 @@
(cond-expand (cond-expand
;(kawa #t) ; JVM
(windows (pffi-define-library pffi-libc-stdlib (windows (pffi-define-library pffi-libc-stdlib
'("stdlib.h") '("stdlib.h")
"ucrtbase" "ucrtbase"
@ -12,12 +11,10 @@
(cond-expand (cond-expand
(chibi #t) ; FIXME (chibi #t) ; FIXME
(else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)))) (else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
(pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(cond-expand (cond-expand
(chibi #t) ; FIXME (chibi #t) ; FIXME
(else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer)))) (else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
#;(define pffi-pointer-null
(lambda ()
; Make aligned_alloc fail and return us a null pointer
(pffi-pointer-allocate-aligned -1 -1)))

107
retropikzel/pffi/shared/struct.scm
View File

@ -1,3 +1,4 @@
(pffi-define-library pffi-libc-stdlib '("ffi.h") "ffi" '())
(define-record-type <pffi-struct> (define-record-type <pffi-struct>
(struct-make c-type size pointer members) (struct-make c-type size pointer members)
@ -7,47 +8,87 @@
(pointer pffi-struct-pointer) (pointer pffi-struct-pointer)
(members pffi-struct-members)) (members pffi-struct-members))
(define-syntax pffi-define-struct
(syntax-rules ()
((_ name c-type members)
(define name
(lambda arguments
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
(size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (if (and (not (null? arguments))
(pffi-pointer? (car arguments)))
(car arguments)
(pffi-pointer-allocate size)))
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type-string size pointer offsets)))))))
(define pffi-struct-dereference
(lambda (struct)
(let ((pointer (pffi-pointer-allocate (pffi-struct-size struct)))
(offset 0))
(for-each
(lambda (struct-member)
(let* ((member-type (cadr struct-member))
(member-name (car struct-member))
(member-size (pffi-size-of member-type)))
(display "HERE: ")
(write member-size)
(newline)
(pffi-pointer-set! pointer
member-type
offset
(pffi-struct-get struct member-name))
(set! offset (+ offset member-size))))
(pffi-struct-members struct))
;(pffi-pointer-get (pffi-struct-pointer struct) 'pointer 0)
;(pffi-pointer-get pointer 'pointer 0)
pointer
)))
(define pffi-align-of (define pffi-align-of
(lambda (type) (lambda (type)
(cond-expand (cond-expand
;(guile (alignof (pffi-type->native-type type))) ;(guile (alignof (pffi-type->native-type type)))
(else (size-of-type type))))) (else (size-of-type type)))))
(define (round-to-next-modulo-of to-round roundee) (define round-to-next-modulo-of
(if (= (floor-remainder to-round roundee) 0) (lambda (to-round roundee)
to-round (if (= (floor-remainder to-round roundee) 0)
(round-to-next-modulo-of (+ to-round 1) roundee))) to-round
(round-to-next-modulo-of (+ to-round 1) roundee))))
(define (calculate-struct-size-and-offsets members) (define calculate-struct-size-and-offsets
(let* ((size 0) (lambda (members)
(largest-member-size 0) (let* ((size 0)
(offsets (map (lambda (member) (largest-member-size 0)
(let* ((name (cdr member)) (offsets (map (lambda (member)
(type (car member)) (let* ((name (cdr member))
(type-alignment (pffi-align-of type))) (type (car member))
(when (> (size-of-type type) largest-member-size) (type-alignment (pffi-align-of type)))
(set! largest-member-size (size-of-type type))) (when (> (size-of-type type) largest-member-size)
(if (or (= size 0) (set! largest-member-size (size-of-type type)))
(= (floor-remainder size type-alignment) 0)) (if (or (= size 0)
(begin (= (floor-remainder size type-alignment) 0))
(set! size (+ size type-alignment)) (begin
(list name type (- size type-alignment))) (set! size (+ size type-alignment))
(let ((next-alignment (round-to-next-modulo-of size type-alignment))) (list name type (- size type-alignment)))
(set! size (+ next-alignment type-alignment)) (let ((next-alignment (round-to-next-modulo-of size type-alignment)))
(list name (set! size (+ next-alignment type-alignment))
type (list name
next-alignment))))) type
members))) next-alignment)))))
(list (cons 'size members)))
(cond-expand (list (cons 'size
;(guile (sizeof (map pffi-type->native-type (map car members)))) (cond-expand
(else ;(guile (sizeof (map pffi-type->native-type (map car members))))
(if (= (modulo size largest-member-size) 0) (else
size (if (= (modulo size largest-member-size) 0)
(round-to-next-modulo-of size largest-member-size))))) size
(cons 'offsets offsets)))) (round-to-next-modulo-of size largest-member-size)))))
(cons 'offsets offsets)))))
(define pffi-struct-make #;(define pffi-struct-make
(lambda (c-type members . pointer) (lambda (c-type members . pointer)
(for-each (for-each
(lambda (member) (lambda (member)

4
retropikzel/pffi/ypsilon.scm
View File

@ -25,8 +25,8 @@
((eq? type 'void) 0) ((eq? type 'void) 0)
(else #f)))) (else #f))))
(define c-malloc (c-function void* malloc (size_t))) ;(define c-malloc (c-function void* malloc (size_t)))
(define c-free (c-function int free (void*))) ;(define c-free (c-function int free (void*)))
#;(define pffi-pointer-allocate #;(define pffi-pointer-allocate
(lambda (size) (lambda (size)

34
src/libtest.c
View File

@ -160,11 +160,11 @@ EXPORT int color_check(struct color* color) {
printf("C: Value of r is %c\n", color->r); printf("C: Value of r is %c\n", color->r);
assert(color->r == 100); assert(color->r == 100);
printf("C: Value of g is %c\n", color->g); printf("C: Value of g is %c\n", color->g);
assert(color->g == 100); assert(color->g == 101);
printf("C: Value of b is %c\n", color->b); printf("C: Value of b is %c\n", color->b);
assert(color->b == 100); assert(color->b == 102);
printf("C: Value of a is %c\n", color->a); printf("C: Value of a is %c\n", color->a);
assert(color->a == 100); assert(color->a == 103);
return 0; return 0;
} }
@ -223,33 +223,33 @@ EXPORT int test_check(struct test* test) {
EXPORT int test_check_by_value(struct test test) { EXPORT int test_check_by_value(struct test test) {
print_offsets(); print_offsets();
printf("C: Value of a is %i\n", test.a); printf("C: Value of a is %i\n", test.a);
//assert(test.a == 1); assert(test.a == 1);
printf("C: Value of b is %c\n", test.b); printf("C: Value of b is %c\n", test.b);
//assert(test.b == 'b'); assert(test.b == 'b');
printf("C: Value of c is %lf\n", test.c); printf("C: Value of c is %lf\n", test.c);
//assert(test.c == 3.0); assert(test.c == 3.0);
printf("C: Value of d is %c\n", test.d); printf("C: Value of d is %c\n", test.d);
//assert(test.d == 'd'); assert(test.d == 'd');
printf("C: Value of e is %s\n", test.e); printf("C: Value of e is %s\n", test.e);
//assert(test.e == NULL); assert(test.e == NULL);
printf("C: Value of f is %f\n", test.f); printf("C: Value of f is %f\n", test.f);
//assert(test.f == 6.0); assert(test.f == 6.0);
printf("C: Value of g is %f\n", test.g); printf("C: Value of g is %f\n", test.g);
//assert(strcmp(test.g, "foo") == 0); assert(strcmp(test.g, "foo") == 0);
printf("C: Value of h is %i\n", test.h); printf("C: Value of h is %i\n", test.h);
//assert(test.h == 8); assert(test.h == 8);
printf("C: Value of i is %s\n", test.i); printf("C: Value of i is %s\n", test.i);
//assert(test.i == NULL); assert(test.i == NULL);
printf("C: Value of j is %i\n", test.j); printf("C: Value of j is %i\n", test.j);
//assert(test.j == 10); assert(test.j == 10);
printf("C: Value of k is %i\n", test.k); printf("C: Value of k is %i\n", test.k);
//assert(test.k == 11); assert(test.k == 11);
printf("C: Value of l is %i\n", test.l); printf("C: Value of l is %i\n", test.l);
//assert(test.l == 12); assert(test.l == 12);
printf("C: Value of m is %i\n", test.m); printf("C: Value of m is %i\n", test.m);
//assert(test.m == 13); assert(test.m == 13);
printf("C: Value of n is %i\n", test.n); printf("C: Value of n is %i\n", test.n);
//assert(test.n == 14); assert(test.n == 14);
} }
EXPORT struct test* test_new() { EXPORT struct test* test_new() {

247
tests/compliance.scm
View File

@ -548,36 +548,41 @@
(debug (pffi-pointer-get set-pointer 'double offset)) (debug (pffi-pointer-get set-pointer 'double offset))
(assert = (pffi-pointer-get set-pointer 'double offset) 1.5) (assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
; pffi-struct-make ; pffi-define-struct
(print-header "pffi-struct") (print-header "pffi-define-struct")
(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) (pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b)))
(define struct1 (test-struct1))
(debug struct1) (debug struct1)
(debug (pffi-size-of struct1)) (debug (pffi-size-of struct1))
(assert = (pffi-size-of struct1) 12) (assert = (pffi-size-of struct1) 12)
(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (pffi-define-struct test-struct2 'test2 '((int8 . r) (int8 . g) (int . b)))
(define struct2 (test-struct2))
(debug struct2) (debug struct2)
(debug (pffi-size-of struct2)) (debug (pffi-size-of struct2))
(assert = (pffi-size-of struct2) 8) (assert = (pffi-size-of struct2) 8)
(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (pffi-define-struct test-struct3 'test3 '((int8 . r) (int8 . g) (int . b)))
(define struct3 (test-struct3))
(debug struct3) (debug struct3)
(debug (pffi-size-of struct3)) (debug (pffi-size-of struct3))
(assert = (pffi-size-of struct3) 8) (assert = (pffi-size-of struct3) 8)
(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) (pffi-define-struct test-struct4 'test4 '((int8 . r) (pointer . a) (int8 . g) (int . b)))
(define struct4 (test-struct4))
(debug struct4) (debug struct4)
(debug (pffi-size-of struct4)) (debug (pffi-size-of struct4))
(assert = (pffi-size-of struct4) 24) (assert = (pffi-size-of struct4) 24)
(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) (pffi-define-struct test-struct5 'test5 '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))
(define struct5 (test-struct5))
(debug struct5) (debug struct5)
(debug (pffi-size-of struct5)) (debug (pffi-size-of struct5))
(assert = (pffi-size-of struct5) 24) (assert = (pffi-size-of struct5) 24)
(define struct6 (pffi-struct-make 'test '((int8 . a) (pffi-define-struct test-struct6 'test6 '((int8 . a)
(char . b) (char . b)
(double . c) (double . c)
(char . d) (char . d)
@ -590,7 +595,8 @@
(int . k) (int . k)
(int . l) (int . l)
(double . m) (double . m)
(float . n)))) (float . n)))
(define struct6 (test-struct6))
(debug struct6) (debug struct6)
(debug (pffi-size-of struct6)) (debug (pffi-size-of struct6))
(assert = (pffi-size-of struct6) 96) (assert = (pffi-size-of struct6) 96)
@ -726,7 +732,7 @@
(pffi-define c-init-struct c-testlib 'init_struct 'pointer '(pointer)) (pffi-define c-init-struct c-testlib 'init_struct 'pointer '(pointer))
(pffi-define c-check-offset c-testlib 'check_offset 'void '(int int)) (pffi-define c-check-offset c-testlib 'check_offset 'void '(int int))
(define struct-test (pffi-struct-make 'test (pffi-define-struct struct-test-get1 'test_get1
'((int8 . a) '((int8 . a)
(char . b) (char . b)
(double . c) (double . c)
@ -740,7 +746,8 @@
(int . k) (int . k)
(int . l) (int . l)
(double . m) (double . m)
(float . n)))) (float . n)))
(define struct-test (struct-test-get1))
(c-check-offset 1 (pffi-struct-offset-get struct-test 'a)) (c-check-offset 1 (pffi-struct-offset-get struct-test 'a))
(c-check-offset 2 (pffi-struct-offset-get struct-test 'b)) (c-check-offset 2 (pffi-struct-offset-get struct-test 'b))
(c-check-offset 3 (pffi-struct-offset-get struct-test 'c)) (c-check-offset 3 (pffi-struct-offset-get struct-test 'c))
@ -796,7 +803,7 @@
(print-header "pffi-struct-set! 1") (print-header "pffi-struct-set! 1")
(pffi-define c-test-check c-testlib 'test_check 'int '(pointer)) (pffi-define c-test-check c-testlib 'test_check 'int '(pointer))
(define struct-test1 (pffi-struct-make 'test (pffi-define-struct struct-test-set1 'test_set1
'((int8 . a) '((int8 . a)
(char . b) (char . b)
(double . c) (double . c)
@ -810,7 +817,8 @@
(int . k) (int . k)
(int . l) (int . l)
(double . m) (double . m)
(float . n)))) (float . n)))
(define struct-test1 (struct-test-set1))
(pffi-struct-set! struct-test1 'a 1) (pffi-struct-set! struct-test1 'a 1)
(pffi-struct-set! struct-test1 'b #\b) (pffi-struct-set! struct-test1 'b #\b)
(pffi-struct-set! struct-test1 'c 3.0) (pffi-struct-set! struct-test1 'c 3.0)
@ -827,13 +835,13 @@
(pffi-struct-set! struct-test1 'n 14.0) (pffi-struct-set! struct-test1 'n 14.0)
(c-test-check (pffi-struct-pointer struct-test1)) (c-test-check (pffi-struct-pointer struct-test1))
;; pffi-struct-make with pointer ;; pffi-struct constructor with pointer
(print-header "pffi-struct-make with pointer") ;(print-header "pffi-struct constructor with pointer")
(pffi-define c-test-new c-testlib 'test_new 'pointer '()) ;(pffi-define c-test-new c-testlib 'test_new 'pointer '())
(define struct-test2-pointer (c-test-new)) ;(define struct-test2-pointer (c-test-new))
(define struct-test2 (pffi-struct-make 'test #;(define struct-test2 (pffi-struct-make 'test
'((int8 . a) '((int8 . a)
(char . b) (char . b)
(double . c) (double . c)
@ -849,40 +857,40 @@
(double . m) (double . m)
(float . n)) (float . n))
struct-test2-pointer)) struct-test2-pointer))
(debug struct-test2) ;(debug struct-test2)
(debug (pffi-pointer-get struct-test2-pointer 'int8 0)) ;(debug (pffi-pointer-get struct-test2-pointer 'int8 0))
(debug (pffi-struct-get struct-test2 'a)) ;(debug (pffi-struct-get struct-test2 'a))
(assert = (pffi-struct-get struct-test2 'a) 1) ;(assert = (pffi-struct-get struct-test2 'a) 1)
(debug (pffi-pointer-get struct-test2-pointer 'char 1)) ;(debug (pffi-pointer-get struct-test2-pointer 'char 1))
(debug (pffi-struct-get struct-test2 'b)) ;(debug (pffi-struct-get struct-test2 'b))
(assert char=? (pffi-struct-get struct-test2 'b) #\b) ;(assert char=? (pffi-struct-get struct-test2 'b) #\b)
(debug (pffi-struct-get struct-test2 'c)) ;(debug (pffi-struct-get struct-test2 'c))
(assert = (pffi-struct-get struct-test2 'c) 3) ;(assert = (pffi-struct-get struct-test2 'c) 3)
(debug (pffi-struct-get struct-test2 'd)) ;(debug (pffi-struct-get struct-test2 'd))
(assert char=? (pffi-struct-get struct-test2 'd) #\d) ;(assert char=? (pffi-struct-get struct-test2 'd) #\d)
(debug (pffi-struct-get struct-test2 'e)) ;(debug (pffi-struct-get struct-test2 'e))
(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) ;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e)))
(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) ;(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t)
(debug (pffi-struct-get struct-test2 'f)) ;(debug (pffi-struct-get struct-test2 'f))
(assert = (pffi-struct-get struct-test2 'f) 6.0) ;(assert = (pffi-struct-get struct-test2 'f) 6.0)
(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) ;(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g)))
(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) ;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t)
(debug (pffi-struct-get struct-test2 'h)) ;(debug (pffi-struct-get struct-test2 'h))
(assert = (pffi-struct-get struct-test2 'h) 8) ;(assert = (pffi-struct-get struct-test2 'h) 8)
(debug (pffi-struct-get struct-test2 'i)) ;(debug (pffi-struct-get struct-test2 'i))
(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) ;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i)))
(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) ;(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t)
(debug (pffi-struct-get struct-test2 'j)) ;(debug (pffi-struct-get struct-test2 'j))
(assert = (pffi-struct-get struct-test2 'j) 10) ;(assert = (pffi-struct-get struct-test2 'j) 10)
(debug (pffi-struct-get struct-test2 'k)) ;(debug (pffi-struct-get struct-test2 'k))
(assert = (pffi-struct-get struct-test2 'k) 11) ;(assert = (pffi-struct-get struct-test2 'k) 11)
(debug (pffi-struct-get struct-test2 'l)) ;(debug (pffi-struct-get struct-test2 'l))
(assert = (pffi-struct-get struct-test2 'l) 12) ;(assert = (pffi-struct-get struct-test2 'l) 12)
(debug (pffi-struct-get struct-test2 'm)) ;(debug (pffi-struct-get struct-test2 'm))
(assert = (pffi-struct-get struct-test2 'm) 13.0) ;(assert = (pffi-struct-get struct-test2 'm) 13.0)
(debug (pffi-struct-get struct-test2 'n)) ;(debug (pffi-struct-get struct-test2 'n))
(assert = (pffi-struct-get struct-test2 'n) 14.0) ;(assert = (pffi-struct-get struct-test2 'n) 14.0)
; Array utilities ; Array utilities
@ -891,78 +899,93 @@
(define test-list1 (list 1 2 3)) (define test-list1 (list 1 2 3))
(debug test-list1) (debug test-list1)
(debug (pffi-list->array 'int test-list1)) (debug (pffi-list->array 'int test-list1))
(assert equal? (pffi-array->list 'int (pffi-list->array 'int test-list1) 3) test-list1) (assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1)
(define test-array1 (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) (define test-array1 (pffi-pointer-allocate (* (pffi-size-of 'int) 3)))
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 0) 4) (pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 0) 4)
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 1) 5) (pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 1) 5)
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 2) 6) (pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 2) 6)
(debug test-array1) (debug test-array1)
(debug (pffi-array->list 'int test-array1 3)) (debug (pffi-array->list (pffi-pointer->array test-array1 'int 3)))
(define check-list1 (list 4 5 6)) (define check-list1 (list 4 5 6))
(assert equal? (pffi-array->list 'int test-array1 3) check-list1) (assert equal? (pffi-array->list (pffi-pointer->array test-array1 'int 3)) check-list1)
;; pffi-struct-dereference (define test-array2 (pffi-array-allocate 'int 5))
(debug (pffi-array->list test-array2))
(assert equal? (pffi-array->list test-array2) (list 0 0 0 0 0))
(pffi-array-set! test-array2 2 1)
(debug (pffi-array->list test-array2))
(assert equal? (pffi-array->list test-array2) (list 0 0 1 0 0))
(assert = (pffi-array-get test-array2 1) 0)
(assert = (pffi-array-get test-array2 2) 1)
(assert = (pffi-array-get test-array2 3) 0)
;(print-header "pffi-struct-dereference 1") ;; pffi-struct-dereference 1
;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(uint32))
#;(define struct-color (pffi-struct-make 'color '((int8 . r)
(int8 . g)
(int8 . b)
(int8 . a))))
;(debug (pffi-struct-set! struct-color 'r 100))
;(debug (pffi-struct-set! struct-color 'g 101))
;(debug (pffi-struct-set! struct-color 'b 102))
;(debug (pffi-struct-set! struct-color 'a 103))
;(assert = (c-color-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-color))) 0)
;(print-header "pffi-struct-dereference 2") (print-header "pffi-struct-dereference 1")
(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color)))
(pffi-define-struct make-struct-color 'color '((int8 . r)
(int8 . g)
(int8 . b)
(int8 . a)))
(define struct-color (make-struct-color))
(debug (pffi-struct-set! struct-color 'r 100))
(debug (pffi-struct-set! struct-color 'g 101))
(debug (pffi-struct-set! struct-color 'b 102))
(debug (pffi-struct-set! struct-color 'a 103))
(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0)
;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(int)) (exit 0)
#;(define struct-test3 (pffi-struct-make 'test
'((int8 . a) (print-header "pffi-struct-dereference 2")
(char . b)
(double . c) (pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test)))
(char . d) (pffi-define-struct make-struct-test-dereference2
(pointer . e) 'test
(float . f) '((int8 . a)
(pointer . g) (char . b)
(int8 . h) (double . c)
(pointer . i) (char . d)
(int . j) (pointer . e)
(int . k) (float . f)
(int . l) (pointer . g)
(double . m) (int8 . h)
(float . n)))) (pointer . i)
;(debug (pffi-struct-set! struct-test3 'a 1)) (int . j)
;(debug (pffi-struct-set! struct-test3 'b #\b)) (int . k)
;(debug (pffi-struct-set! struct-test3 'c 3.0)) (int . l)
;(debug (pffi-struct-set! struct-test3 'd #\d)) (double . m)
;(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) (float . n)))
;(debug (pffi-struct-set! struct-test3 'f 6.0)) (define struct-test3 (make-struct-test-dereference2))
;(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) (debug (pffi-struct-set! struct-test3 'a 1))
;(debug (pffi-struct-set! struct-test3 'h 8)) (debug (pffi-struct-set! struct-test3 'b #\b))
;(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) (debug (pffi-struct-set! struct-test3 'c 3.0))
;(debug (pffi-struct-set! struct-test3 'j 10)) (debug (pffi-struct-set! struct-test3 'd #\d))
;(debug (pffi-struct-set! struct-test3 'k 11)) (debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null)))
;(debug (pffi-struct-set! struct-test3 'l 12)) (debug (pffi-struct-set! struct-test3 'f 6.0))
;(debug (pffi-struct-set! struct-test3 'm 13.0)) (debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo")))
;(debug (pffi-struct-set! struct-test3 'n 14.0)) (debug (pffi-struct-set! struct-test3 'h 8))
;(debug (pffi-struct-get struct-test3 'a)) (debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null)))
;(debug (pffi-struct-get struct-test3 'b)) (debug (pffi-struct-set! struct-test3 'j 10))
;(debug (pffi-struct-get struct-test3 'c)) (debug (pffi-struct-set! struct-test3 'k 11))
;(debug (pffi-struct-get struct-test3 'd)) (debug (pffi-struct-set! struct-test3 'l 12))
;(debug (pffi-struct-get struct-test3 'e)) (debug (pffi-struct-set! struct-test3 'm 13.0))
;(debug (pffi-struct-get struct-test3 'f)) (debug (pffi-struct-set! struct-test3 'n 14.0))
;(debug (pffi-struct-get struct-test3 'g)) (debug (pffi-struct-get struct-test3 'a))
;(debug (pffi-struct-get struct-test3 'h)) (debug (pffi-struct-get struct-test3 'b))
;(debug (pffi-struct-get struct-test3 'i)) (debug (pffi-struct-get struct-test3 'c))
;(debug (pffi-struct-get struct-test3 'j)) (debug (pffi-struct-get struct-test3 'd))
;(debug (pffi-struct-get struct-test3 'k)) (debug (pffi-struct-get struct-test3 'e))
;(debug (pffi-struct-get struct-test3 'l)) (debug (pffi-struct-get struct-test3 'f))
;(debug (pffi-struct-get struct-test3 'm)) (debug (pffi-struct-get struct-test3 'g))
;(debug (pffi-struct-get struct-test3 'n)) (debug (pffi-struct-get struct-test3 'h))
;(c-test-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-test3))) (debug (pffi-struct-get struct-test3 'i))
(debug (pffi-struct-get struct-test3 'j))
(debug (pffi-struct-get struct-test3 'k))
(debug (pffi-struct-get struct-test3 'l))
(debug (pffi-struct-get struct-test3 'm))
(debug (pffi-struct-get struct-test3 'n))
(c-test-check-by-value (pffi-struct-dereference struct-test3))
;; pffi-define-callback ;; pffi-define-callback