Move to running tests with scheme_runner

old-tests/100_hello.scm

@@ -0,0 +1,7 @@
+(import (scheme base)
+        (scheme write))
+
+(display "Hello")
+(newline)
+
+

old-tests/200_import.scm

@@ -0,0 +1,8 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel r7rs-pffi version main))
+
+(display "Hello from import.scm")
+(newline)
+
+

old-tests/300_size-of.scm

@@ -0,0 +1,80 @@
+(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)

old-tests/400_pointer-allocate-free.scm

@@ -0,0 +1,14 @@
+(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)
+
+

old-tests/401_is-pointer.scm

@@ -0,0 +1,12 @@
+(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"))
+
+

old-tests/402_null-pointer.scm

@@ -0,0 +1,14 @@
+(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"))
+
+

old-tests/410_pointer-set-get.scm

@@ -0,0 +1,31 @@
+(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))
+
+

old-tests/500_string-to-pointer-to-string.scm

@@ -0,0 +1,17 @@
+(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)
+
+

old-tests/600_libc.scm

@@ -0,0 +1,21 @@
+(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)

old-tests/700_pffi-define.scm

@@ -0,0 +1,21 @@
+(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)

old-tests/800_libcurl.scm

@@ -0,0 +1,56 @@
+(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 <curl/curl.h>
+; 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)