Portable foreign function interface for R7RS. It is portable in the sense that it supports multiple implementations, as opposed to being portable by conforming to some @@ -36,56 +35,81 @@ Documentation - 0.6.0
-Currently the interface of the library is in okay shape. It propably will not change much but no guarantees are being made just yet.
-Due to supporting many different Scheme implementations, - different parts of this software are in different stage. As a - whole it is still in alpha stage. That said the - interface should not be changing anymore and some - implementations are in beta.
| pffi-init | pffi-size-of | -pffi-shared-object-auto-load | -pffi-shared-object-load | +pffi-define-library | pffi-pointer-null | pffi-pointer-null? | -pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | -pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | -pffi-string->pointer | -pffi-pointer->string | -pffi-struct-make | -pffi-struct-pointer | -pffi-struct-offset-get | -pffi-struct-get | -pffi-struct-set! | pffi-define | pffi-define-callback | X | X | X | ++ + | ||||||||||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Chicken | +X | +X | +X | +X | +X | +X | +X | +X | +X | +X | +X | +||||||||||||||||||||||||||||||||||
| Cyclone | +X | +X | +X | +X | +X | ++ | X | +X | +X | +X | ++ | ||||||||||||||||||||||||||||||||||
| Gambit | +X | +X | ++ | + | + | X | ++ | + | + | + | + | ||||||||||||||||||||||||||||||||||
| Gauche | X | X | X | @@ -214,27 +270,17 @@ Documentation - 0.6.0||||||||||||||||||||||||||||||||||||||||||
| Gauche | -X | -X | -X | -X | -X | -X | +Gerbil | X | - | X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | ++ | + | + | + | + | + | + | |||||||||||||||||
| X | X | X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | X | X | X | @@ -270,15 +306,33 @@ Documentation - 0.6.0X | X | X | +X | +X | +X | +X | +|||||||||||||||||||||||
| Larceny | +X | + | + | + | + | + | + | + | + | + | + | ||||||||||||||||||||||||||||||||||
| Mosh | X | X | X | X | X | -X | -X | -X | +X | X | X | @@ -294,16 +348,6 @@ Documentation - 0.6.0X | X | X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | X | X | X | @@ -318,217 +362,6 @@ Documentation - 0.6.0X | X | X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -
| - | pffi-init | -pffi-size-of | -pffi-shared-object-auto-load | -pffi-shared-object-load | -pffi-pointer-null | -pffi-pointer-null? | -pffi-pointer-allocate | -pffi-pointer-address | -pffi-pointer? | -pffi-pointer-free | -pffi-pointer-set! | -pffi-pointer-get | -pffi-string->pointer | -pffi-pointer->string | -pffi-struct-make | -pffi-struct-pointer | -pffi-struct-offset-get | -pffi-struct-get | -pffi-struct-set! | -pffi-define | -pffi-define-callback | -||||||||||||
|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|---|
| Chicken-5 | -X | -X | -X | -X | -X | -X | -X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -||||||||||||
| Cyclone | -X | -X | -X | -X | -X | -X | -X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -X | -- | ||||||||||||
| Gambit | -X | -X | -- | - | - | - | - | X | -- | - | - | - | - | - | X | -X | -X | -X | -X | -- | - | ||||||||||||
| Gerbil | -X | -- | - | - | - | - | - | - | - | - | - | - | - | - | X | -X | -X | -X | -X | -- | - | ||||||||||||
| Larceny | -X | -- | - | - | - | - | - | - | - | - | - | - | - | - | X | -X | -X | -X | -X | -- | - | ||||||||||||
| Mosh | -X | -X | -X | -X | -X | -X | -X | -- | X | -X | -X | -X | -X | -X | -X | -X | -X | X | X | X | @@ -547,16 +380,6 @@ Documentation - 0.6.0- | - | - | - | X | -X | -X | -X | -X | -- | |||
| Stklos | @@ -565,22 +388,12 @@ Documentation - 0.6.0X | X | X | -X | -X | X | -X | - | X | -X | -X | -X | -X | -- | |||||||||||||||||||
| tr7 | @@ -595,43 +408,45 @@ Documentation - 0.6.0- | - | - | - | X | -X | -X | -X | -X | -- | |||||||||||||||||||||||
| Ypsilon | -- | - | - | - | - | - | - | - | - | - | - | - | - | X | X | X | X | X | -- | + | X | +X | +X | +X | +X | +X |
These features are built upon the primitives and if + primitives are implemented and work, they should work too.
+Some implementations have extra dependencies/requirements + beyond just the library.
Needs libffi-dev, on Debina/Ubuntu/Mint install with:
+ +Building depends on libffi.
+Debian/Ubuntu/Mint install with:
apt install libffi-devBuild with:
-make chibiNeeds r7rs - egg, install with:
+ +Chicken needs r7rs egg installed. Install it with:
chicken-install r7rsBuilding depends on libffi.
+Debian/Ubuntu/Mint install with:
+apt install libffi-devNeeds racket-r7rs, install with:
raco pkg install --auto r7rsKawa Needs at least Java version 22
-Needs jvm flags:
+ +Kawa Needs at least Java version 22 these flags before any + other arguments:
If you are running kawa.jar with plain java then give same + arguments to java without the -J prefix.
+Since the project is under active development is best to + clone it from git,
+Assuming you + have a project and your libraries live in directory called snow + in it:
+git clone https://git.sr.ht/~retropikzel/r7rs-pffi
+mkdir -p snow
+cp -r r7rs-pffi/retropikzel snow/
+cd snow/retropikzel/pffi
+make <SCHEME>There is no build scripts yet for Windows, that said many + implementations work without compiling anything. If you run this + and it says “There is notching to build for SCHEME” then you + should be good to go.
+Still work in progress.
Setting environment variables like this on Windows works for + this library:
+set "PFFI_LOAD_PATH=C:\Program Files (x86)/foo/bar"To add more paths to where pffi looks for libraries set + PFFI_LOAD_PATH to paths separated by ; on windows, and : on + other operating systems.
Some of these are procedures and some macros, it might also change implementation to implementation.
-pffi-init
Always call this first, on most implementation it does nothing but some implementations might need initialisation run.
-pffi-size-of object -> number
Returns the size of the pffi-struct, pffi-enum or pffi-type.
-pffi-align-of type -> number
Returns the align of the type.
-pffi-shared-object-auto-load headers +
pffi-define-library headers shared-object-name [options] -> object
Load given shared object automatically searching many predefined paths.
@@ -800,69 +655,68 @@ Documentation - 0.6.0Example:
-(define libc-stdlib
- (cond-expand
- (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
- (else (pffi-shared-object-auto-load (list "stdlib.h")
- "c"
- '(additional-versions . ("6"))
- '(additional-search-paths . ("."))))))pffi-shared-object-load headers path - [options]
-It is recommended to use the pffi-shared-object-auto-load - instead of this directly.
-Headers is a list of strings needed to be included, for - example
-(list "curl/curl.h")Path is the full path of the shared object without any “lib” - prefix or “.so/.dll” suffix. For example:
-"curl"Options:
+(cond-expand
+ (windows (pffi-define-library libc-stdlib
+ '("stdlib.h")
+ "ucrtbase"
+ '((additional-versions ("0" "6"))
+ (additiona-paths (".")))))
+ (else (pffi-define-library libc-stdlib
+ (list "stdlib.h")
+ "c"
+ '((additional-versions ("0" "6"))
+ (additiona-paths ("."))))))pffi-pointer-null -> pointer
Returns a new NULL pointer.
-pffi-pointer-null? pointer -> boolean
Returns #t if given pointer is null pointer, #f otherwise.
-pffi-pointer-allocate size -> pointer
Returns newly allocated pointer of given size.
-pffi-pointer-address pointer -> number
Returns the address of given pointer as number.
-pffi-pointer? object -> boolean
Returns #t if given object is pointer, #f otherwise.
-pffi-pointer-free pointer
Frees given pointer.
-pffi-pointer-set! pointer type offset value
Sets the value on a pointer on given offset. For example:
(define p (pffi-pointer-allocate 128))
(pffi-pointer-set! p 'int 64 100)Would set the offset of 64, on pointer p to value 100.
-pffi-pointer-get pointer type offset -> object
Gets the value from a pointer on given offset. For @@ -871,18 +725,18 @@ Documentation - 0.6.0 (pffi-pointer-set! p 'int 64 100) (pffi-pointer-get p 'int 64) > 100 -
pffi-string->pointer string -> pointer
Makes pointer out of a given string.
-pffi-pointer->string pointer -> string
Makes string out of a given pointer.
-pffi-struct-make c-type members . pointer -> pffi-struct
Creates a new pffi-struct and allocates pointer for it. The @@ -891,8 +745,8 @@ Documentation - 0.6.0
(define color (pffi-struct-make 'color '((int8 . r) (int8 . g) (int8 . b) (int8 .a ))))
(define test (pffi-struct-make "struct test" '((int8 . r) (int8 . g) (int8 . b) (int8 .a ))))C-type argument can be symbol or a string.
-pffi-struct-pointer pffi-struct -> pointer
Returns the pointer that holds the struct content. You need @@ -900,52 +754,85 @@ Documentation - 0.6.0 functions.
(define s (pffi-struct-make 'test '((int . r) (int . g) (int . b))))
(pffi-struct-pointer s)pffi-struct-offset-get member-name -> number
Returns the offset of a struct member with given name.
-pffi-struct-get pffi-struct member-name -> object
Returns the value of the givens struct member.
-pffi-struct-set! pffi-struct member-name value
Sets the value of the givens struct member. It is up to you to make sure that the type of value is correct.
-pffi-define scheme-name shared-object c-name - return-type argument-types
+pffi-array-allocate type size
+Allocates pointer array of given type and size.
+pffi-array-pointer array
+Returns the pointer of the array.
+pffi-array? object
+Returns #t of given object is array, #f otherwise.
+pffi-pointer->array pointer type size
+Converts given pointer to an array of giben type and + size.
+pffi-array-get array index
+Returns the value of given index from given array.
+pffi-array-set! array index value
+Sets the given value of given index in given array.
+pffi-list->array type list
+Converts given list into C array of given type.
+pffi-array->list type list length
+Converts given C array into list of given type and + length.
+pffi-define-function scheme-name + shared-object c-name return-type argument-types
Defines a new foreign function to be used from Scheme code. For example:
-(define libc-stdlib
- (cond-expand
- (windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")))
- (else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6")))))
-(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer))
+ (cond-expand
+ (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
+ (else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6"))))
+(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
(c-puts "Message brought to you by FFI!")
- pffi-define-callback
-
+ pffi-define-callback
+
pffi-define-callback scheme-name return-type
argument-types procedure
Defines a new Sceme function to be used as callback to C
code. For example:
; Load the shared library
-(define libc-stdlib
- (cond-expand
- (windows (pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list "")))
- (else (pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" "6")))))
+(cond-expand
+ (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
+ (else (pffi-define-library '("stdlib.h") "c" '("" "6"))))
; Define C function that takes a callback
-(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))
+(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
; Define our callback
(pffi-define-callback compare
'int
- (list 'pointer 'pointer)
+ '(pointer pointer)
(lambda (pointer-a pointer-b)
(let ((a (pffi-pointer-get pointer-a 'int 0))
(b (pffi-pointer-get pointer-b 'int 0)))
diff --git a/documentation/R7RS-PFFI.pdf b/documentation/R7RS-PFFI.pdf
index 5eb7294..ad9a951 100644
Binary files a/documentation/R7RS-PFFI.pdf and b/documentation/R7RS-PFFI.pdf differ
diff --git a/old-tests/100_hello b/old-tests/100_hello
deleted file mode 100755
index e6372c6..0000000
Binary files a/old-tests/100_hello and /dev/null differ
diff --git a/old-tests/100_hello.scm b/old-tests/100_hello.scm
deleted file mode 100644
index 21d8b43..0000000
--- a/old-tests/100_hello.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-(import (scheme base)
- (scheme write))
-
-(display "Hello")
-(newline)
-
-
diff --git a/old-tests/200_import b/old-tests/200_import
deleted file mode 100755
index 68f0502..0000000
Binary files a/old-tests/200_import and /dev/null differ
diff --git a/old-tests/200_import.scm b/old-tests/200_import.scm
deleted file mode 100644
index c33b004..0000000
--- a/old-tests/200_import.scm
+++ /dev/null
@@ -1,8 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(display "Hello from import.scm")
-(newline)
-
-
diff --git a/old-tests/300_size-of b/old-tests/300_size-of
deleted file mode 100755
index a0f367a..0000000
Binary files a/old-tests/300_size-of and /dev/null differ
diff --git a/old-tests/300_size-of.scm b/old-tests/300_size-of.scm
deleted file mode 100644
index 31da82c..0000000
--- a/old-tests/300_size-of.scm
+++ /dev/null
@@ -1,80 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(display 'int8)
-(display " ")
-(display (pffi-size-of 'int8))
-(newline)
-(display 'uint8)
-(display " ")
-(display (pffi-size-of 'uint8))
-(newline)
-(display 'int16)
-(display " ")
-(display (pffi-size-of 'int16))
-(newline)
-(display 'uint16)
-(display " ")
-(display (pffi-size-of 'uint16))
-(newline)
-(display 'int32)
-(display " ")
-(display (pffi-size-of 'int32))
-(newline)
-(display 'uint32)
-(display " ")
-(display (pffi-size-of 'uint32))
-(newline)
-(display 'int64)
-(display " ")
-(display (pffi-size-of 'int64))
-(newline)
-(display 'uint64)
-(display " ")
-(display (pffi-size-of 'uint64))
-(newline)
-(display 'char)
-(display " ")
-(display (pffi-size-of 'char))
-(newline)
-(display 'unsigned-char)
-(display " ")
-(display (pffi-size-of 'unsigned-char))
-(newline)
-(display 'short)
-(display " ")
-(display (pffi-size-of 'short))
-(newline)
-(display 'unsigned-short)
-(display " ")
-(display (pffi-size-of 'unsigned-short))
-(newline)
-(display 'int)
-(display " ")
-(display (pffi-size-of 'int))
-(newline)
-(display 'unsigned-int)
-(display " ")
-(display (pffi-size-of 'unsigned-int))
-(newline)
-(display 'long)
-(display " ")
-(display (pffi-size-of 'long))
-(newline)
-(display 'unsigned-long)
-(display " ")
-(display (pffi-size-of 'unsigned-long))
-(newline)
-(display 'float)
-(display " ")
-(display (pffi-size-of 'float))
-(newline)
-(display 'double)
-(display " ")
-(display (pffi-size-of 'double))
-(newline)
-(display 'pointer)
-(display " ")
-(display (pffi-size-of 'pointer))
-(newline)
diff --git a/old-tests/400_pointer-allocate-free.scm b/old-tests/400_pointer-allocate-free.scm
deleted file mode 100644
index d1c27eb..0000000
--- a/old-tests/400_pointer-allocate-free.scm
+++ /dev/null
@@ -1,14 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
- (* (pffi-size-of 'uint8) 4)
- (pffi-size-of 'int))))
-
-(write p)
-(newline)
-
-(pffi-pointer-free p)
-
-
diff --git a/old-tests/401_is-pointer.scm b/old-tests/401_is-pointer.scm
deleted file mode 100644
index c370549..0000000
--- a/old-tests/401_is-pointer.scm
+++ /dev/null
@@ -1,12 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
- (* (pffi-size-of 'uint8) 4)
- (pffi-size-of 'int))))
-
-(if (not (pffi-pointer? p)) (error "pffi-pointer? returned false when given pointer"))
-(if (pffi-pointer? "Hello") (error "pffi-pointer? returned true when given not a pointer"))
-
-
diff --git a/old-tests/402_null-pointer.scm b/old-tests/402_null-pointer.scm
deleted file mode 100644
index 8491620..0000000
--- a/old-tests/402_null-pointer.scm
+++ /dev/null
@@ -1,14 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
- (* (pffi-size-of 'uint8) 4)
- (pffi-size-of 'int))))
-(define n (pffi-pointer-null))
-
-(if (not (pffi-pointer-null? n)) (error "pffi-pointer-null? returned false when given null pointer"))
-(if (pffi-pointer-null? p) (error "pffi-pointer-null? returned true when given not a null pointer"))
-(if (pffi-pointer-null? "Hello") (error "pffi-pointer-null? returned true when given not a pointer"))
-
-
diff --git a/old-tests/410_pointer-set-get.scm b/old-tests/410_pointer-set-get.scm
deleted file mode 100644
index 885df30..0000000
--- a/old-tests/410_pointer-set-get.scm
+++ /dev/null
@@ -1,31 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(define p (pffi-pointer-allocate (+ (* (pffi-size-of 'uint32) 3)
- (* (pffi-size-of 'uint8) 4)
- (pffi-size-of 'int))))
-
-(write p)
-(newline)
-
-(pffi-pointer-set! p
- 'uint8
- (+ (* (pffi-size-of 'uint32))
- (* (pffi-size-of 'uint8) 2))
- 42)
-
-(write p)
-(newline)
-
-(let ((result(pffi-pointer-get p
- 'uint8
- (+ (* (pffi-size-of 'uint32))
- (* (pffi-size-of 'uint8) 2)))))
- (if (not (= result 42))
- (error "pffi-pointer-get did not return 42"))
-
- (write result)
- (newline))
-
-
diff --git a/old-tests/500_string-to-pointer-to-string.scm b/old-tests/500_string-to-pointer-to-string.scm
deleted file mode 100644
index 520b8ef..0000000
--- a/old-tests/500_string-to-pointer-to-string.scm
+++ /dev/null
@@ -1,17 +0,0 @@
-(import (scheme base)
- (scheme write)
- (retropikzel r7rs-pffi version main))
-
-(define original "Hello world")
-
-(define p (pffi-string->pointer original))
-(write p)
-(newline)
-
-(define s (pffi-pointer->string p))
-(if (not (string=? original s))
- (error (string-append "string from pointer is not " original) s))
-(write s)
-(newline)
-
-
diff --git a/old-tests/600_libc.scm b/old-tests/600_libc.scm
deleted file mode 100644
index c905878..0000000
--- a/old-tests/600_libc.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-(import (scheme base)
- (scheme write)
- (scheme process-context)
- (scheme eval)
- (retropikzel r7rs-pffi version main))
-
-(define libc
- (if (string=? pffi-os-name "windows")
- (pffi-shared-object-auto-load (list "stdio.h") (list) "ucrtbase" (list ""))
- (pffi-shared-object-auto-load (list "stdio.h") (list) "c" (list "" ".6"))))
-
-(pffi-define puts libc 'puts 'int (list 'pointer))
-
-(display "=================")
-(newline)
-
-(puts (pffi-string->pointer "This is from C"))
-
-(newline)
-(display "=================")
-(newline)
diff --git a/old-tests/700_pffi-define.scm b/old-tests/700_pffi-define.scm
deleted file mode 100644
index 7908687..0000000
--- a/old-tests/700_pffi-define.scm
+++ /dev/null
@@ -1,21 +0,0 @@
-(import (scheme base)
- (scheme write)
- (scheme process-context)
- (scheme eval)
- (retropikzel r7rs-pffi version main))
-
-(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h")
- (list)
- "curl"
- (list ".4")))
-
-(pffi-define curl-version libcurl 'curl_version 'string (list))
-
-(display "=================")
-(newline)
-
-(display (pffi-pointer->string (curl-version)))
-
-(newline)
-(display "=================")
-(newline)
diff --git a/old-tests/800_libcurl.scm b/old-tests/800_libcurl.scm
deleted file mode 100644
index 768fe01..0000000
--- a/old-tests/800_libcurl.scm
+++ /dev/null
@@ -1,56 +0,0 @@
-(import (scheme base)
- (scheme write)
- (scheme process-context)
- (retropikzel r7rs-pffi version main))
-
-(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers
- (list ".") ; Additional search paths
- "curl" ; The named of shared object without the lib prefix
- (list ".4"))) ;Additional versions to search
-
-(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list))
-
-; Define the curl-easy-setopt twice since some implementations (Sagittarius) complain if you pass
-; callback type instead of pointer type
-(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer))
-(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback))
-
-(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer))
-
-;These values need to be get from c file like this:
-; #include
-; int main() {
-; printf("Value: %d", CURLOPT_WRITEFUNCTION);
-; }
-; many times you can get them from .h files directly
-(define CURLOPT-WRITEFUNCTION 20011)
-(define CURLOPT-FOLLOWLOCATION 52)
-(define CURLOPT-URL 10002)
-
-(define result "")
-(pffi-define-callback collect-result
- 'void
- (list 'pointer 'int 'int 'pointer)
- (lambda (pointer size nmemb client-pointer)
- (set! result (string-append result (pffi-pointer->string pointer)))))
-
-(define handle (curl-easy-init))
-(define url (pffi-string->pointer "https://scheme.org"))
-(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url))
-(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
-(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
-(display "Curl code 1: ")
-(display curl-code1)
-(newline)
-(display "Curl code 2: ")
-(display curl-code2)
-(newline)
-(display "Curl code 3: ")
-(display curl-code3)
-(newline)
-(display "Perform: ")
-(write (curl-easy-perform handle))
-(newline)
-(display "Response length: ")
-(display (string-length result))
-(newline)
diff --git a/retropikzel/pffi.rkt b/retropikzel/pffi.rkt
deleted file mode 100644
index 4498eda..0000000
--- a/retropikzel/pffi.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "pffi.sld")
diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld
index a9a277b..ae098ac 100644
--- a/retropikzel/pffi.sld
+++ b/retropikzel/pffi.sld
@@ -164,7 +164,7 @@
pffi-array-set!
pffi-list->array
pffi-array->list
- pffi-define
+ pffi-define-function
pffi-define-callback)
(cond-expand
(chibi (include "pffi/chibi.scm"))
diff --git a/retropikzel/pffi/chibi-src/pffi.stub b/retropikzel/pffi/chibi-src/pffi.stub
index 8b187a2..7354e47 100644
--- a/retropikzel/pffi/chibi-src/pffi.stub
+++ b/retropikzel/pffi/chibi-src/pffi.stub
@@ -186,7 +186,7 @@
;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }")
;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*)))
-;; pffi-define
+;; pffi-define-function
(c-declare "ffi_cif cif;")
(define-c (pointer void*) dlsym ((maybe-null pointer void*) string))
diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm
index 890bed5..c914484 100644
--- a/retropikzel/pffi/chibi.scm
+++ b/retropikzel/pffi/chibi.scm
@@ -136,7 +136,7 @@
((equal? type 'callback) '(maybe-null void*))
(else (error "pffi-type->native-type -- No such pffi type" type)))))
-;; pffi-define
+;; pffi-define-function
(define pffi-type->libffi-type
(lambda (type)
@@ -193,9 +193,9 @@
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
@@ -208,6 +208,6 @@
(define-syntax pffi-define-callback
(syntax-rules ()
- ((pffi-define scheme-name return-type argument-types procedure)
+ ((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback return-type 'argument-types procedure)))))
diff --git a/retropikzel/pffi/chicken.scm b/retropikzel/pffi/chicken.scm
index 6d798f3..370180e 100644
--- a/retropikzel/pffi/chicken.scm
+++ b/retropikzel/pffi/chicken.scm
@@ -29,7 +29,7 @@
(lambda (object)
(pointer? object)))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type ; Chicken has this procedure in three places
@@ -148,33 +148,6 @@
(lambda ()
(address->pointer 0)))
-;(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
-;(pffi-define puts #f 'puts 'int (list 'pointer))
-;(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
-
-#;(define pffi-string->pointer
- (lambda (string-content)
- (let* ((size (string-length string-content))
- (pointer (pffi-pointer-allocate (+ size 1))))
- (memset pointer 0 (+ size 1))
- (strncpy-ps pointer (location string-content) size)
- ;(puts pointer)
- pointer)))
-
-#;(define pffi-string->pointer
- (foreign-lambda* c-pointer
- ((c-string str))
- "C_return((void*)str);"))
-
-
-;(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
-;(pffi-define strlen #f 'strlen 'int (list 'pointer))
-
-#;(define pffi-pointer->string
- (foreign-lambda* c-string
- ((c-pointer p))
- "C_return((char*)p);"))
-
(define-syntax pffi-shared-object-load
(er-macro-transformer
(lambda (expr rename compare)
diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm
index 5390da7..6948847 100644
--- a/retropikzel/pffi/cyclone.scm
+++ b/retropikzel/pffi/cyclone.scm
@@ -27,7 +27,7 @@
(lambda (object)
(opaque? object)))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(er-macro-transformer
(lambda (expr rename compare)
(let* ((pffi-type->native-type
diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm
index f0d9ad1..b7aef6c 100644
--- a/retropikzel/pffi/gambit.scm
+++ b/retropikzel/pffi/gambit.scm
@@ -167,7 +167,7 @@
((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
(define-macro
- (pffi-define scheme-name shared-object c-name return-type argument-types)
+ (pffi-define-function scheme-name shared-object c-name return-type argument-types)
(letrec* ((native-argument-types
(if (equal? '(list) argument-types)
(list)
diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm
index f98f627..91837a6 100644
--- a/retropikzel/pffi/gauche.scm
+++ b/retropikzel/pffi/gauche.scm
@@ -168,9 +168,9 @@
(cond ((not (equal? return-type 'void))
(pffi-pointer-get return-value return-type 0))))))))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(symbol->string c-name)
@@ -183,6 +183,6 @@
(define-syntax pffi-define-callback
(syntax-rules ()
- ((pffi-define scheme-name return-type argument-types procedure)
+ ((_ scheme-name return-type argument-types procedure)
(define scheme-name
(make-c-callback return-type 'argument-types procedure)))))
diff --git a/retropikzel/pffi/gerbil.scm b/retropikzel/pffi/gerbil.scm
index 4b046f7..cd726ad 100644
--- a/retropikzel/pffi/gerbil.scm
+++ b/retropikzel/pffi/gerbil.scm
@@ -6,9 +6,9 @@
(lambda (object)
(error "Not defined")))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(error "Not defined"))))
(define size-of-type
diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm
index e6927c4..d776977 100644
--- a/retropikzel/pffi/guile.scm
+++ b/retropikzel/pffi/guile.scm
@@ -29,9 +29,9 @@
(lambda (object)
(pointer? object)))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(foreign-library-function shared-object
(symbol->string c-name)
@@ -40,7 +40,7 @@
(define-syntax pffi-define-callback
(syntax-rules ()
- ((pffi-define-callback scheme-name return-type argument-types procedure)
+ ((_ scheme-name return-type argument-types procedure)
(define scheme-name
(procedure->pointer (pffi-type->native-type return-type)
procedure
diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm
index cd169c6..0ce506b 100644
--- a/retropikzel/pffi/kawa.scm
+++ b/retropikzel/pffi/kawa.scm
@@ -59,9 +59,9 @@
(string=? (invoke (invoke object 'getClass) 'getName)
"jdk.internal.foreign.NativeMemorySegmentImpl")))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((pffi-define-function scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(lambda vals
(invoke (invoke (cdr (assoc 'linker shared-object))
diff --git a/retropikzel/pffi/larceny.scm b/retropikzel/pffi/larceny.scm
index 0406b4a..8f92241 100644
--- a/retropikzel/pffi/larceny.scm
+++ b/retropikzel/pffi/larceny.scm
@@ -122,9 +122,9 @@
((equal? type 'void) (%peek-pointer (+ pointer offset)))
((equal? type 'pointer) (%peek-pointer (+ pointer offset))))))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
0
@@ -135,7 +135,7 @@
(define-syntax pffi-define-callback
(syntax-rules ()
- ((pffi-define scheme-name return-type argument-types procedure)
+ ((_ scheme-name return-type argument-types procedure)
(define scheme-name
0
#;(make-c-callback return-type argument-types procedure)))))
diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm
index 0baae48..5a15eca 100644
--- a/retropikzel/pffi/mosh.scm
+++ b/retropikzel/pffi/mosh.scm
@@ -139,9 +139,9 @@
((equal? type 'struct) 'void*)
(else (error "pffi-type->native-type -- No such pffi type" type)))))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(make-c-function shared-object
(pffi-type->native-type return-type)
diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm
index a96f28a..e890647 100644
--- a/retropikzel/pffi/racket.scm
+++ b/retropikzel/pffi/racket.scm
@@ -29,9 +29,9 @@
(lambda (object)
(cpointer? object)))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
(get-ffi-obj c-name
shared-object
diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm
index d1cfe5e..4835926 100644
--- a/retropikzel/pffi/sagittarius.scm
+++ b/retropikzel/pffi/sagittarius.scm
@@ -30,7 +30,7 @@
(or (pointer? object)
(string? object))))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
((_ scheme-name shared-object c-name return-type argument-types)
(define scheme-name
diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm
index 069fa83..5b1a047 100644
--- a/retropikzel/pffi/shared/pointer.scm
+++ b/retropikzel/pffi/shared/pointer.scm
@@ -10,11 +10,10 @@
(cond-expand
(chibi #t) ; FIXME
- (else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
+ (else (pffi-define-function 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-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
+(pffi-define-function pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(cond-expand
(chibi #t) ; FIXME
- (else (pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
+ (else (pffi-define-function pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer))))
diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm
index 2c9e8aa..89ffe90 100644
--- a/retropikzel/pffi/stklos.scm
+++ b/retropikzel/pffi/stklos.scm
@@ -33,9 +33,9 @@
(newline)
(cpointer? object)))
-(define-syntax pffi-define
+(define-syntax pffi-define-function
(syntax-rules ()
- ((pffi-define scheme-name shared-object c-name return-type argument-types)
+ ((_ scheme-name shared-object c-name return-type argument-types)
(begin
(define pffi-type->native-type
(lambda (type)
diff --git a/retropikzel/pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm
index a7554b8..5dd9386 100644
--- a/retropikzel/pffi/ypsilon.scm
+++ b/retropikzel/pffi/ypsilon.scm
@@ -144,7 +144,7 @@
(else (error "pffi-type->native-type -- No such pffi type" ,type))))
(define-macro
- (pffi-define scheme-name shared-object c-name return-type argument-types)
+ (pffi-define-function scheme-name shared-object c-name return-type argument-types)
`(define ,scheme-name
(c-function ,(pffi-type->native-type return-type)
,(cadr c-name)
diff --git a/snow/arvyy/mustache-test.rkt b/snow/arvyy/mustache-test.rkt
deleted file mode 100644
index 8fc6f94..0000000
--- a/snow/arvyy/mustache-test.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "mustache-test.sld")
diff --git a/snow/arvyy/mustache.rkt b/snow/arvyy/mustache.rkt
deleted file mode 100644
index 6fc0ec6..0000000
--- a/snow/arvyy/mustache.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "mustache.sld")
diff --git a/snow/arvyy/mustache/collection.rkt b/snow/arvyy/mustache/collection.rkt
deleted file mode 100644
index 7318926..0000000
--- a/snow/arvyy/mustache/collection.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "collection.sld")
diff --git a/snow/arvyy/mustache/executor.rkt b/snow/arvyy/mustache/executor.rkt
deleted file mode 100644
index c0b4d57..0000000
--- a/snow/arvyy/mustache/executor.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "executor.sld")
diff --git a/snow/arvyy/mustache/lookup.rkt b/snow/arvyy/mustache/lookup.rkt
deleted file mode 100644
index 12fe7c9..0000000
--- a/snow/arvyy/mustache/lookup.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "lookup.sld")
diff --git a/snow/arvyy/mustache/parser.rkt b/snow/arvyy/mustache/parser.rkt
deleted file mode 100644
index 0197f4b..0000000
--- a/snow/arvyy/mustache/parser.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "parser.sld")
diff --git a/snow/arvyy/mustache/tokenizer.rkt b/snow/arvyy/mustache/tokenizer.rkt
deleted file mode 100644
index 7a0e152..0000000
--- a/snow/arvyy/mustache/tokenizer.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "tokenizer.sld")
diff --git a/test.rkt b/test.rkt
deleted file mode 100644
index 995d424..0000000
--- a/test.rkt
+++ /dev/null
@@ -1,914 +0,0 @@
-#lang r7rs
-(import (scheme base)
- (scheme write)
- (scheme char)
- (scheme process-context)
- (retropikzel pffi))
-
-(define header-count 1)
-
-(define print-header
- (lambda (title)
- (set-tag title)
- (display "=========================================")
- (newline)
- (display header-count)
- (display " ")
- (display title)
- (newline)
- (display "=========================================")
- (newline)
- (set! header-count (+ header-count 1))))
-
-(define count 0)
-(define assert-tag 'none)
-
-(define set-tag
- (lambda (tag)
- (set! assert-tag tag)
- (set! count 0)))
-
-(define-syntax assert
- (syntax-rules ()
- ((_ check value-a value-b)
- (let ((result (apply check (list value-a value-b))))
- (set! count (+ count 1))
- (if (not result) (display "FAIL ") (display "PASS "))
- (display "[")
- (display assert-tag)
- (display " - ")
- (display count)
- (display "]")
- (display ": ")
- (write (list 'check 'value-a 'value-b))
- (newline)
- (when (not result) (exit 1))))))
-
-(define-syntax debug
- (syntax-rules ()
- ((_ value)
- (begin
- (display 'value)
- (display ": ")
- (write value)
- (newline)))))
-
-;; pffi-init
-
-(print-header 'pffi-init)
-
-(pffi-init)
-
-;; pffi-type?
-
-(print-header 'pffi-type?)
-
-(debug (pffi-type? 'int8))
-(assert equal? (pffi-type? 'int8) #t)
-(debug (pffi-type? 'uint8))
-(assert equal? (pffi-type? 'uint8) #t)
-(debug (pffi-type? 'int16))
-(assert equal? (pffi-type? 'int16) #t)
-(debug (pffi-type? 'uint16))
-(assert equal? (pffi-type? 'uint16) #t)
-(debug (pffi-type? 'int32))
-(assert equal? (pffi-type? 'int32) #t)
-(debug (pffi-type? 'uint32))
-(assert equal? (pffi-type? 'uint32) #t)
-(debug (pffi-type? 'int64))
-(assert equal? (pffi-type? 'int64) #t)
-(debug (pffi-type? 'uint64))
-(assert equal? (pffi-type? 'uint64) #t)
-(debug (pffi-type? 'char))
-(assert equal? (pffi-type? 'char) #t)
-(debug (pffi-type? 'unsigned-char))
-(assert equal? (pffi-type? 'unsigned-char) #t)
-(debug (pffi-type? 'short))
-(assert equal? (pffi-type? 'short) #t)
-(debug (pffi-type? 'unsigned-short))
-(assert equal? (pffi-type? 'unsigned-short) #t)
-(debug (pffi-type? 'int))
-(assert equal? (pffi-type? 'int) #t)
-(debug (pffi-type? 'unsigned-int))
-(assert equal? (pffi-type? 'unsigned-int) #t)
-(debug (pffi-type? 'long))
-(assert equal? (pffi-type? 'long) #t)
-(debug (pffi-type? 'unsigned-long))
-(assert equal? (pffi-type? 'unsigned-long) #t)
-(debug (pffi-type? 'float))
-(assert equal? (pffi-type? 'float) #t)
-(debug (pffi-type? 'double))
-(assert equal? (pffi-type? 'double) #t)
-(debug (pffi-type? 'string))
-(assert equal? (pffi-type? 'string) #t)
-(debug (pffi-type? 'pointer))
-(assert equal? (pffi-type? 'pointer) #t)
-(debug (pffi-type? 'void))
-(assert equal? (pffi-type? 'void) #t)
-(debug (pffi-type? 'callback))
-(assert equal? (pffi-type? 'callback) #t)
-
-(pffi-init)
-
-;; pffi-size-of
-
-(print-header 'pffi-size-of)
-
-(define size-int8 (pffi-size-of 'int8))
-(debug size-int8)
-(assert equal? (number? size-int8) #t)
-(assert = size-int8 1)
-
-(define size-uint8 (pffi-size-of 'uint8))
-(debug size-uint8)
-(assert equal? (number? size-uint8) #t)
-(assert = size-uint8 1)
-
-(assert equal? (number? (pffi-size-of 'uint8)) #t)
-(define size-int16 (pffi-size-of 'int16))
-(debug size-int16)
-(assert equal? (number? size-int16) #t)
-(assert = size-int16 2)
-
-(assert equal? (number? (pffi-size-of 'int16)) #t)
-(define size-uint16 (pffi-size-of 'uint16))
-(debug size-uint16)
-(assert equal? (number? size-uint16) #t)
-(assert = size-uint16 2)
-
-(assert equal? (number? (pffi-size-of 'uint16)) #t)
-(define size-int32 (pffi-size-of 'int32))
-(debug size-int32)
-(assert equal? (number? size-int32) #t)
-(assert = size-int32 4)
-
-(assert equal? (number? (pffi-size-of 'int32)) #t)
-(define size-uint32 (pffi-size-of 'uint32))
-(debug size-uint32)
-(assert equal? (number? size-uint32) #t)
-(assert = size-uint32 4)
-
-(assert equal? (number? (pffi-size-of 'uint32)) #t)
-(define size-int64 (pffi-size-of 'int64))
-(debug size-int64)
-(assert equal? (number? size-int64) #t)
-(assert = size-int64 8)
-
-(assert equal? (number? (pffi-size-of 'int64)) #t)
-(define size-uint64 (pffi-size-of 'uint64))
-(debug size-uint64)
-(assert equal? (number? size-uint64) #t)
-(assert = size-uint64 8)
-
-(assert equal? (number? (pffi-size-of 'uint64)) #t)
-(define size-char (pffi-size-of 'char))
-(debug size-char)
-(assert equal? (number? size-char) #t)
-(assert = size-char 1)
-
-(assert equal? (number? (pffi-size-of 'char)) #t)
-(define size-unsigned-char (pffi-size-of 'unsigned-char))
-(debug size-unsigned-char)
-(assert equal? (number? size-unsigned-char) #t)
-(assert = size-unsigned-char 1)
-
-(assert equal? (number? (pffi-size-of 'unsigned-char)) #t)
-(define size-short (pffi-size-of 'short))
-(debug size-short)
-(assert equal? (number? size-short) #t)
-(assert = size-short 2)
-
-(assert equal? (number? (pffi-size-of 'short)) #t)
-(define size-unsigned-short (pffi-size-of 'unsigned-short))
-(debug size-unsigned-short)
-(assert equal? (number? size-unsigned-short) #t)
-(assert = size-unsigned-short 2)
-
-(assert equal? (number? (pffi-size-of 'unsigned-short)) #t)
-(define size-int (pffi-size-of 'int))
-(debug size-int)
-(assert equal? (number? size-int) #t)
-(assert = size-int 4)
-
-(assert equal? (number? (pffi-size-of 'int)) #t)
-(define size-unsigned-int (pffi-size-of 'unsigned-int))
-(debug size-unsigned-int)
-(assert equal? (number? size-unsigned-int) #t)
-(assert = size-unsigned-int 4)
-
-(cond-expand
- (i386
- (assert equal? (number? (pffi-size-of 'long)) #t)
- (define size-long (pffi-size-of 'long))
- (debug size-long)
- (assert equal? (number? size-long) #t)
- (assert = size-long 4))
- (else
- (assert equal? (number? (pffi-size-of 'long)) #t)
- (define size-long (pffi-size-of 'long))
- (debug size-long)
- (assert equal? (number? size-long) #t)
- (assert = size-long 8)))
-
-(cond-expand
- (i386
- (assert equal? (number? (pffi-size-of 'unsigned-long)) #t)
- (define size-unsigned-long (pffi-size-of 'unsigned-long))
- (debug size-unsigned-long)
- (assert equal? (number? size-unsigned-long) #t)
- (assert = size-unsigned-long 4))
- (else
- (assert equal? (number? (pffi-size-of 'long)) #t)
- (define size-unsigned-long (pffi-size-of 'unsigned-long))
- (debug size-unsigned-long)
- (assert equal? (number? size-unsigned-long) #t)
- (assert = size-unsigned-long 8)))
-
-(assert equal? (number? (pffi-size-of 'float)) #t)
-(define size-float (pffi-size-of 'float))
-(debug size-float)
-(assert equal? (number? size-float) #t)
-(assert = size-float 4)
-
-(assert equal? (number? (pffi-size-of 'double)) #t)
-(define size-double (pffi-size-of 'double))
-(debug size-double)
-(assert equal? (number? size-double) #t)
-(assert = size-double 8)
-
-(cond-expand
- (i386
- (define size-pointer (pffi-size-of 'pointer))
- (debug size-pointer)
- (assert equal? (number? size-pointer) #t)
- (assert = size-pointer 4))
- (else
- (define size-pointer (pffi-size-of 'pointer))
- (debug size-pointer)
- (assert equal? (number? size-pointer) #t)
- (assert = size-pointer 8)))
-
-;; pffi-align-of
-
-(print-header 'pffi-align-of)
-
-(define align-int8 (pffi-align-of 'int8))
-(debug align-int8)
-(assert equal? (number? align-int8) #t)
-(assert = align-int8 1)
-
-(define align-uint8 (pffi-align-of 'uint8))
-(debug align-uint8)
-(assert equal? (number? align-uint8) #t)
-(assert = align-uint8 1)
-
-(assert equal? (number? (pffi-align-of 'uint8)) #t)
-(define align-int16 (pffi-align-of 'int16))
-(debug align-int16)
-(assert equal? (number? align-int16) #t)
-(assert = align-int16 2)
-
-(assert equal? (number? (pffi-align-of 'int16)) #t)
-(define align-uint16 (pffi-align-of 'uint16))
-(debug align-uint16)
-(assert equal? (number? align-uint16) #t)
-(assert = align-uint16 2)
-
-(assert equal? (number? (pffi-align-of 'uint16)) #t)
-(define align-int32 (pffi-align-of 'int32))
-(debug align-int32)
-(assert equal? (number? align-int32) #t)
-(assert = align-int32 4)
-
-(assert equal? (number? (pffi-align-of 'int32)) #t)
-(define align-uint32 (pffi-align-of 'uint32))
-(debug align-uint32)
-(assert equal? (number? align-uint32) #t)
-(assert = align-uint32 4)
-
-(assert equal? (number? (pffi-align-of 'uint32)) #t)
-(define align-int64 (pffi-align-of 'int64))
-(debug align-int64)
-(assert equal? (number? align-int64) #t)
-(assert = align-int64 8)
-
-(assert equal? (number? (pffi-align-of 'int64)) #t)
-(define align-uint64 (pffi-align-of 'uint64))
-(debug align-uint64)
-(assert equal? (number? align-uint64) #t)
-(assert = align-uint64 8)
-
-(assert equal? (number? (pffi-align-of 'uint64)) #t)
-(define align-char (pffi-align-of 'char))
-(debug align-char)
-(assert equal? (number? align-char) #t)
-(assert = align-char 1)
-
-(assert equal? (number? (pffi-align-of 'char)) #t)
-(define align-unsigned-char (pffi-align-of 'unsigned-char))
-(debug align-unsigned-char)
-(assert equal? (number? align-unsigned-char) #t)
-(assert = align-unsigned-char 1)
-
-(assert equal? (number? (pffi-align-of 'unsigned-char)) #t)
-(define align-short (pffi-align-of 'short))
-(debug align-short)
-(assert equal? (number? align-short) #t)
-(assert = align-short 2)
-
-(assert equal? (number? (pffi-align-of 'short)) #t)
-(define align-unsigned-short (pffi-align-of 'unsigned-short))
-(debug align-unsigned-short)
-(assert equal? (number? align-unsigned-short) #t)
-(assert = align-unsigned-short 2)
-
-(assert equal? (number? (pffi-align-of 'unsigned-short)) #t)
-(define align-int (pffi-align-of 'int))
-(debug align-int)
-(assert equal? (number? align-int) #t)
-(assert = align-int 4)
-
-(assert equal? (number? (pffi-align-of 'int)) #t)
-(define align-unsigned-int (pffi-align-of 'unsigned-int))
-(debug align-unsigned-int)
-(assert equal? (number? align-unsigned-int) #t)
-(assert = align-unsigned-int 4)
-
-(cond-expand
- (i386
- (assert equal? (number? (pffi-align-of 'long)) #t)
- (define align-long (pffi-align-of 'long))
- (debug align-long)
- (assert equal? (number? align-long) #t)
- (assert = align-long 4))
- (else
- (assert equal? (number? (pffi-align-of 'long)) #t)
- (define align-long (pffi-align-of 'long))
- (debug align-long)
- (assert equal? (number? align-long) #t)
- (assert = align-long 8)))
-
-(cond-expand
- (i386
- (assert equal? (number? (pffi-align-of 'unsigned-long)) #t)
- (define align-unsigned-long (pffi-align-of 'unsigned-long))
- (debug align-unsigned-long)
- (assert equal? (number? align-unsigned-long) #t)
- (assert = align-unsigned-long 4))
- (else
- (assert equal? (number? (pffi-align-of 'long)) #t)
- (define align-unsigned-long (pffi-align-of 'unsigned-long))
- (debug align-unsigned-long)
- (assert equal? (number? align-unsigned-long) #t)
- (assert = align-unsigned-long 8)))
-
-(assert equal? (number? (pffi-align-of 'float)) #t)
-(define align-float (pffi-align-of 'float))
-(debug align-float)
-(assert equal? (number? align-float) #t)
-(assert = align-float 4)
-
-(assert equal? (number? (pffi-align-of 'double)) #t)
-(define align-double (pffi-align-of 'double))
-(debug align-double)
-(assert equal? (number? align-double) #t)
-(assert = align-double 8)
-
-(cond-expand
- (i386
- (define align-pointer (pffi-align-of 'pointer))
- (debug align-pointer)
- (assert equal? (number? align-pointer) #t)
- (assert = align-pointer 4))
- (else
- (define align-pointer (pffi-align-of 'pointer))
- (debug align-pointer)
- (assert equal? (number? align-pointer) #t)
- (assert = align-pointer 8)))
-
-;; pffi-shared-object-auto-load
-
-(print-header 'pffi-shared-object-auto-load)
-
-(define libc-stdlib
- (cond-expand
- (windows (pffi-shared-object-auto-load (list "stdlib.h") "ucrtbase"))
- (else (pffi-shared-object-auto-load (list "stdlib.h")
- "c"
- '(additional-versions . ("0" "6"))))))
-
-(debug libc-stdlib)
-
-(define c-testlib
- (cond-expand
- (windows (pffi-shared-object-auto-load (list "libtest.h")
- "test"
- '(additional-paths . ("."))))
- (else (pffi-shared-object-auto-load (list "libtest.h")
- "test"
- '(additional-paths . ("."))))))
-
-(debug c-testlib)
-
-;; pffi-pointer-null
-
-(print-header 'pffi-pointer-null)
-
-(define null-pointer (pffi-pointer-null))
-(debug null-pointer)
-(assert equal? (pffi-pointer-null? null-pointer) #t)
-
-;; pffi-pointer-null?
-
-(print-header 'pffi-pointer-null?)
-
-(define is-null-pointer (pffi-pointer-null))
-(debug is-null-pointer)
-(assert equal? (pffi-pointer-null? is-null-pointer) #t)
-(assert equal? (pffi-pointer-null? 100) #f)
-(assert equal? (pffi-pointer-null? 'bar) #f)
-
-;; pffi-pointer-allocate
-
-(print-header 'pffi-pointer-allocate)
-
-(define test-pointer (pffi-pointer-allocate 100))
-(debug test-pointer)
-(assert equal? (pffi-pointer? test-pointer) #t)
-(assert equal? (pffi-pointer-null? test-pointer) #f)
-
-;; pffi-pointer-address
-
-(print-header 'pffi-pointer-allocate)
-
-(define test-pointer1 (pffi-pointer-allocate 100))
-(debug test-pointer1)
-(debug (pffi-pointer? test-pointer1))
-(assert equal? (pffi-pointer? test-pointer1) #t)
-;(debug (pffi-pointer-address test-pointer1))
-;(assert equal? (number? (pffi-pointer-address test-pointer1)) #t)
-
-;; pffi-pointer?
-
-(print-header 'pffi-pointer?)
-
-(define is-pointer (pffi-pointer-allocate 100))
-(debug is-pointer)
-(assert equal? (pffi-pointer? is-pointer) #t)
-(assert equal? (pffi-pointer? 100) #f)
-(assert equal? (pffi-pointer? 'bar) #f)
-
-;; pffi-pointer-free
-
-(print-header 'pffi-pointer-free)
-
-(define pointer-to-be-freed (pffi-pointer-allocate 100))
-(debug pointer-to-be-freed)
-(pffi-pointer-free pointer-to-be-freed)
-(debug pointer-to-be-freed)
-
-;; pffi-pointer-set! and pffi-pointer-get 1/2
-
-(print-header "pffi-pointer-set! and pffi-pointer-get 1/2")
-
-(define set-pointer (pffi-pointer-allocate 256))
-(define offset 64)
-(define value 1)
-(debug set-pointer)
-(debug offset)
-(debug value)
-
-(define-syntax test-type
- (syntax-rules ()
- ((_ type)
- (begin
- (pffi-pointer-set! set-pointer type offset value)
- (assert = (pffi-pointer-get set-pointer type offset) value)))))
-
-(test-type 'int8)
-(test-type 'uint8)
-(test-type 'int16)
-(test-type 'uint16)
-(test-type 'int32)
-(test-type 'uint32)
-(test-type 'int64)
-(test-type 'uint64)
-(test-type 'short)
-(test-type 'unsigned-short)
-(test-type 'int)
-(test-type 'unsigned-int)
-(test-type 'long)
-(test-type 'unsigned-long)
-
-(pffi-pointer-set! set-pointer 'char offset #\X)
-(debug (pffi-pointer-get set-pointer 'char offset))
-(assert char=? (pffi-pointer-get set-pointer 'char offset) #\X)
-
-(pffi-pointer-set! set-pointer 'float offset 1.5)
-(debug (pffi-pointer-get set-pointer 'float offset))
-(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
-
-(pffi-pointer-set! set-pointer 'double offset 1.5)
-(debug (pffi-pointer-get set-pointer 'double offset))
-(assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
-
-; pffi-struct-make
-
-(print-header "pffi-struct")
-
-(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b))))
-(debug struct1)
-(debug (pffi-size-of struct1))
-(assert = (pffi-size-of struct1) 12)
-
-(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b))))
-(debug struct2)
-(debug (pffi-size-of struct2))
-(assert = (pffi-size-of struct2) 8)
-
-(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b))))
-(debug struct3)
-(debug (pffi-size-of struct3))
-(assert = (pffi-size-of struct3) 8)
-
-(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b))))
-(debug struct4)
-(debug (pffi-size-of struct4))
-(assert = (pffi-size-of struct4) 24)
-
-(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b))))
-(debug struct5)
-(debug (pffi-size-of struct5))
-(assert = (pffi-size-of struct5) 24)
-
-(define struct6 (pffi-struct-make 'test '((int8 . a)
- (char . b)
- (double . c)
- (char . d)
- (pointer . e)
- (float . f)
- (pointer . g)
- (int8 . h)
- (pointer . i)
- (int . j)
- (int . k)
- (int . l)
- (double . m)
- (float . n))))
-(debug struct6)
-(debug (pffi-size-of struct6))
-(assert = (pffi-size-of struct6) 96)
-
-;; pffi-string->pointer
-
-(print-header 'pffi-string->pointer)
-
-(define string-pointer (pffi-string->pointer "Hello world"))
-(debug string-pointer)
-(debug (pffi-pointer->string string-pointer))
-(assert equal? (pffi-pointer? string-pointer) #t)
-(assert equal? (pffi-pointer-null? string-pointer) #f)
-(debug (pffi-pointer-get string-pointer 'char 0))
-(assert char=? (pffi-pointer-get string-pointer 'char 0) #\H)
-(debug (pffi-pointer-get string-pointer 'char 1))
-(assert char=? (pffi-pointer-get string-pointer 'char 1) #\e)
-(debug (pffi-pointer-get string-pointer 'char 2))
-(assert char=? (pffi-pointer-get string-pointer 'char 2) #\l)
-(debug (pffi-pointer-get string-pointer 'char 3))
-(assert char=? (pffi-pointer-get string-pointer 'char 3) #\l)
-(debug (pffi-pointer-get string-pointer 'char 4))
-(assert char=? (pffi-pointer-get string-pointer 'char 4) #\o)
-(debug (pffi-pointer-get string-pointer 'char 10))
-(assert char=? (pffi-pointer-get string-pointer 'char 10) #\d)
-
-;; pffi-pointer->string
-
-(print-header 'pffi-pointer->string)
-
-(define pointer-string (pffi-pointer->string string-pointer))
-(debug pointer-string)
-(assert equal? (string? pointer-string) #t)
-(assert string=? pointer-string "Hello world")
-(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
-(define test-url-string "https://scheme.org")
-(debug test-url-string)
-(define test-url (pffi-string->pointer test-url-string))
-(debug test-url)
-(debug (pffi-pointer->string test-url))
-(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
-
-;; pffi-pointer-get
-
-(print-header "pffi-pointer-get")
-
-(define hello-string "hello")
-(define hello-string-pointer (pffi-string->pointer hello-string))
-
-(debug (pffi-pointer-get hello-string-pointer 'char 0))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h)
-(debug (pffi-pointer-get hello-string-pointer 'char 1))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 1) #\e)
-(debug (pffi-pointer-get hello-string-pointer 'char 4))
-(assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o)
-
-;; pffi-pointer-set! and pffi-pointer-get 2/2
-
-(print-header "pffi-pointer-set! and pffi-pointer-get 2/2")
-
-(define pointer-to-be-set (pffi-string->pointer "FOOBAR"))
-(debug pointer-to-be-set)
-(debug (pffi-pointer->string pointer-to-be-set))
-(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
-
-(debug (pffi-pointer-get set-pointer 'pointer offset))
-(assert equal?
- (pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset))
- #t)
-(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)))
-(assert equal?
- (string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)))
- #t)
-(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)))
-(assert equal?
- (string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
- #t)
-
-(define string-to-be-set "FOOBAR")
-(debug string-to-be-set)
-(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set))
-(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
-
-;; pffi-define
-
-(print-header 'pffi-define)
-
-(pffi-define c-puts libc-stdlib 'puts 'int (list 'pointer))
-(define chars-written (c-puts (pffi-string->pointer "Hello from testing, I am C function puts")))
-(assert = chars-written 41)
-
-(pffi-define c-atoi libc-stdlib 'atoi 'int (list 'pointer))
-(assert = (c-atoi (pffi-string->pointer "100")) 100)
-
-;; pffi-struct-get
-
-(print-header 'pffi-struct-get)
-
-(pffi-define c-init-struct c-testlib 'init_struct 'pointer (list 'pointer))
-(pffi-define c-check-offset c-testlib 'check_offset 'void (list 'int 'int))
-(define struct-test (pffi-struct-make 'test
- '((int8 . a)
- (char . b)
- (double . c)
- (char . d)
- (pointer . e)
- (float . f)
- (pointer . g)
- (int8 . h)
- (pointer . i)
- (int . j)
- (int . k)
- (int . l)
- (double . m)
- (float . n))))
-(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 3 (pffi-struct-offset-get struct-test 'c))
-(c-check-offset 4 (pffi-struct-offset-get struct-test 'd))
-(c-check-offset 5 (pffi-struct-offset-get struct-test 'e))
-(c-check-offset 6 (pffi-struct-offset-get struct-test 'f))
-(c-check-offset 7 (pffi-struct-offset-get struct-test 'g))
-(c-check-offset 8 (pffi-struct-offset-get struct-test 'h))
-(c-check-offset 9 (pffi-struct-offset-get struct-test 'i))
-(c-check-offset 10 (pffi-struct-offset-get struct-test 'j))
-(c-check-offset 11 (pffi-struct-offset-get struct-test 'k))
-(c-check-offset 12 (pffi-struct-offset-get struct-test 'l))
-(c-check-offset 13 (pffi-struct-offset-get struct-test 'm))
-(c-check-offset 14 (pffi-struct-offset-get struct-test 'n))
-(debug struct-test)
-(c-init-struct (pffi-struct-pointer struct-test))
-(debug struct-test)
-
-(debug (pffi-struct-get struct-test 'a))
-(assert = (pffi-struct-get struct-test 'a) 1)
-(debug (pffi-struct-get struct-test 'b))
-(assert char=? (pffi-struct-get struct-test 'b) #\b)
-(debug (pffi-struct-get struct-test 'c))
-(assert = (pffi-struct-get struct-test 'c) 3.0)
-(debug (pffi-struct-get struct-test 'd))
-(assert char=? (pffi-struct-get struct-test 'd) #\d)
-(debug (pffi-struct-get struct-test 'e))
-(debug (pffi-pointer-null? (pffi-struct-get struct-test 'e)))
-(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t)
-(debug (pffi-struct-get struct-test 'f))
-(assert = (pffi-struct-get struct-test 'f) 6.0)
-(debug (pffi-struct-get struct-test 'g))
-(debug (pffi-pointer->string (pffi-struct-get struct-test 'g)))
-(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t)
-(debug (pffi-struct-get struct-test 'h))
-(assert = (pffi-struct-get struct-test 'h) 8)
-(debug (pffi-struct-get struct-test 'i))
-(debug (pffi-pointer-null? (pffi-struct-get struct-test 'i)))
-(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t)
-(debug (pffi-struct-get struct-test 'j))
-(assert = (pffi-struct-get struct-test 'j) 10)
-(debug (pffi-struct-get struct-test 'k))
-(assert = (pffi-struct-get struct-test 'k) 11)
-(debug (pffi-struct-get struct-test 'l))
-(assert = (pffi-struct-get struct-test 'l) 12)
-(debug (pffi-struct-get struct-test 'm))
-(assert = (pffi-struct-get struct-test 'm) 13.0)
-(debug (pffi-struct-get struct-test 'n))
-(assert = (pffi-struct-get struct-test 'n) 14.0)
-
-;; pffi-struct-set! 1
-
-(print-header "pffi-struct-set! 1")
-
-(pffi-define c-test-check c-testlib 'test_check 'int (list 'pointer))
-(define struct-test1 (pffi-struct-make 'test
- '((int8 . a)
- (char . b)
- (double . c)
- (char . d)
- (pointer . e)
- (float . f)
- (pointer . g)
- (int8 . h)
- (pointer . i)
- (int . j)
- (int . k)
- (int . l)
- (double . m)
- (float . n))))
-(pffi-struct-set! struct-test1 'a 1)
-(pffi-struct-set! struct-test1 'b #\b)
-(pffi-struct-set! struct-test1 'c 3.0)
-(pffi-struct-set! struct-test1 'd #\d)
-(pffi-struct-set! struct-test1 'e (pffi-pointer-null))
-(pffi-struct-set! struct-test1 'f 6.0)
-(pffi-struct-set! struct-test1 'g (pffi-string->pointer "foo"))
-(pffi-struct-set! struct-test1 'h 8)
-(pffi-struct-set! struct-test1 'i (pffi-pointer-null))
-(pffi-struct-set! struct-test1 'j 10)
-(pffi-struct-set! struct-test1 'k 11)
-(pffi-struct-set! struct-test1 'l 12)
-(pffi-struct-set! struct-test1 'm 13.0)
-(pffi-struct-set! struct-test1 'n 14.0)
-(c-test-check (pffi-struct-pointer struct-test1))
-
-;; pffi-struct-make with pointer
-
-(print-header "pffi-struct-make with pointer")
-
-(pffi-define c-test-new c-testlib 'test_new 'pointer (list))
-(define struct-test2-pointer (c-test-new))
-(define struct-test2 (pffi-struct-make 'test
- '((int8 . a)
- (char . b)
- (double . c)
- (char . d)
- (pointer . e)
- (float . f)
- (pointer . g)
- (int8 . h)
- (pointer . i)
- (int . j)
- (int . k)
- (int . l)
- (double . m)
- (float . n))
- struct-test2-pointer))
-(debug struct-test2)
-
-(debug (pffi-pointer-get struct-test2-pointer 'int8 0))
-(debug (pffi-struct-get struct-test2 'a))
-(assert = (pffi-struct-get struct-test2 'a) 1)
-(debug (pffi-pointer-get struct-test2-pointer 'char 1))
-(debug (pffi-struct-get struct-test2 'b))
-(assert char=? (pffi-struct-get struct-test2 'b) #\b)
-(debug (pffi-struct-get struct-test2 'c))
-(assert = (pffi-struct-get struct-test2 'c) 3)
-(debug (pffi-struct-get struct-test2 'd))
-(assert char=? (pffi-struct-get struct-test2 'd) #\d)
-(debug (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)
-(debug (pffi-struct-get struct-test2 'f))
-(assert = (pffi-struct-get struct-test2 'f) 6.0)
-(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g)))
-(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t)
-(debug (pffi-struct-get struct-test2 'h))
-(assert = (pffi-struct-get struct-test2 'h) 8)
-(debug (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)
-(debug (pffi-struct-get struct-test2 'j))
-(assert = (pffi-struct-get struct-test2 'j) 10)
-(debug (pffi-struct-get struct-test2 'k))
-(assert = (pffi-struct-get struct-test2 'k) 11)
-(debug (pffi-struct-get struct-test2 'l))
-(assert = (pffi-struct-get struct-test2 'l) 12)
-(debug (pffi-struct-get struct-test2 'm))
-(assert = (pffi-struct-get struct-test2 'm) 13.0)
-(debug (pffi-struct-get struct-test2 'n))
-(assert = (pffi-struct-get struct-test2 'n) 14.0)
-
-;; pffi-struct-dereference
-
-(print-header "pffi-struct-dereference 1")
-(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int (list 'struct))
-(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-struct-dereference struct-color)) 0)
-
-(print-header "pffi-struct-dereference 2")
-
-(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int (list 'struct))
-(define struct-test3 (pffi-struct-make 'test
- '((int8 . a)
- (char . b)
- (double . c)
- (char . d)
- (pointer . e)
- (float . f)
- (pointer . g)
- (int8 . h)
- (pointer . i)
- (int . j)
- (int . k)
- (int . l)
- (double . m)
- (float . n))))
-(debug (pffi-struct-set! struct-test3 'a 1))
-(debug (pffi-struct-set! struct-test3 'b #\b))
-(debug (pffi-struct-set! struct-test3 'c 3.0))
-(debug (pffi-struct-set! struct-test3 'd #\d))
-(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null)))
-(debug (pffi-struct-set! struct-test3 'f 6.0))
-(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo")))
-(debug (pffi-struct-set! struct-test3 'h 8))
-(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null)))
-(debug (pffi-struct-set! struct-test3 'j 10))
-(debug (pffi-struct-set! struct-test3 'k 11))
-(debug (pffi-struct-set! struct-test3 'l 12))
-(debug (pffi-struct-set! struct-test3 'm 13.0))
-(debug (pffi-struct-set! struct-test3 'n 14.0))
-(debug (pffi-struct-get struct-test3 'a))
-(debug (pffi-struct-get struct-test3 'b))
-(debug (pffi-struct-get struct-test3 'c))
-(debug (pffi-struct-get struct-test3 'd))
-(debug (pffi-struct-get struct-test3 'e))
-(debug (pffi-struct-get struct-test3 'f))
-(debug (pffi-struct-get struct-test3 'g))
-(debug (pffi-struct-get struct-test3 'h))
-(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
-
-(print-header 'pffi-define-callback)
-
-(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3)))
-(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3)
-(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2)
-(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1)
-
-(pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))
-
-(pffi-define-callback compare
- 'int
- (list 'pointer 'pointer)
- (lambda (pointer-a pointer-b)
- (let ((a (pffi-pointer-get pointer-a 'int 0))
- (b (pffi-pointer-get pointer-b 'int 0)))
- (cond ((> a b) 1)
- ((= a b) 0)
- ((< a b) -1)))))
-(write compare)
-(newline)
-
-(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
- (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1))
- (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
-(debug unsorted)
-(assert equal? unsorted (list 3 2 1))
-
-(qsort array 3 (pffi-size-of 'int) compare)
-
-(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0))
- (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1))
- (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2))))
-(debug sorted)
-(assert equal? sorted (list 1 2 3))
-(exit 0)
diff --git a/tests/compliance.scm b/tests/compliance.scm
index 68a1a8d..c1a3a9b 100755
--- a/tests/compliance.scm
+++ b/tests/compliance.scm
@@ -684,31 +684,31 @@
(print-header 'pffi-define)
-(pffi-define c-abs libc-stdlib 'abs 'int '(int))
+(pffi-define-function c-abs libc-stdlib 'abs 'int '(int))
(debug c-abs)
(define absoluted (c-abs -2))
(debug absoluted)
(assert = absoluted 2)
-(pffi-define c-puts libc-stdlib 'puts 'int '(pointer))
+(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
(debug c-puts)
(define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts")))
(debug chars-written)
(assert = chars-written 47)
-(pffi-define c-atoi libc-stdlib 'atoi 'int '(pointer))
+(pffi-define-function c-atoi libc-stdlib 'atoi 'int '(pointer))
(assert = (c-atoi (pffi-string->pointer "100")) 100)
-(pffi-define c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
+(pffi-define-function c-fopen libc-stdio 'fopen 'pointer '(pointer pointer))
(define output-file (c-fopen (pffi-string->pointer "testfile.test")
(pffi-string->pointer "w")))
(debug output-file)
-(pffi-define c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
+(pffi-define-function c-fprintf libc-stdio 'fprintf 'int '(pointer pointer))
(define characters-written
(c-fprintf output-file (pffi-string->pointer "Hello world")))
(debug characters-written)
(assert equal? (= characters-written 11) #t)
-(pffi-define c-fclose libc-stdio 'fclose 'int '(pointer))
+(pffi-define-function c-fclose libc-stdio 'fclose 'int '(pointer))
(define closed-status (c-fclose output-file))
(debug closed-status)
(assert equal? (= closed-status 0) #t)
@@ -717,11 +717,11 @@
(lambda () (read-line)))
"Hello world") #t)
-(pffi-define c-takes-no-args c-testlib 'takes_no_args 'void '())
+(pffi-define-function c-takes-no-args c-testlib 'takes_no_args 'void '())
(debug c-takes-no-args)
(c-takes-no-args)
-(pffi-define c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
+(pffi-define-function c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '())
(debug c-takes-no-args)
(define takes-no-args-returns-int-result (c-takes-no-args-returns-int))
(assert equal? (= takes-no-args-returns-int-result 0) #t)
@@ -730,8 +730,8 @@
(print-header 'pffi-struct-get)
-(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-function c-init-struct c-testlib 'init_struct 'pointer '(pointer))
+(pffi-define-function c-check-offset c-testlib 'check_offset 'void '(int int))
(pffi-define-struct struct-test-get1 'test_get1
'((int8 . a)
(char . b)
@@ -802,7 +802,7 @@
(print-header "pffi-struct-set! 1")
-(pffi-define c-test-check c-testlib 'test_check 'int '(pointer))
+(pffi-define-function c-test-check c-testlib 'test_check 'int '(pointer))
(pffi-define-struct struct-test-set1 'test_set1
'((int8 . a)
(char . b)
@@ -839,7 +839,7 @@
;(print-header "pffi-struct constructor with pointer")
-;(pffi-define c-test-new c-testlib 'test_new 'pointer '())
+;(pffi-define-function c-test-new c-testlib 'test_new 'pointer '())
;(define struct-test2-pointer (c-test-new))
#;(define struct-test2 (pffi-struct-make 'test
'((int8 . a)
@@ -923,7 +923,7 @@
;; pffi-struct-dereference 1
;(print-header "pffi-struct-dereference 1")
-;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color)))
+;(pffi-define-function 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)
@@ -939,7 +939,7 @@
;(print-header "pffi-struct-dereference 2")
-;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test)))
+;(pffi-define-function c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test)))
#;(pffi-define-struct make-struct-test-dereference2
'test
'((int8 . a)
@@ -996,7 +996,7 @@
;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2)
;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1)
-;(pffi-define qsort libc-stdlib 'qsort 'void '(pointer int int callback))
+;(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
#;(pffi-define-callback compare
'int