Moved tests to their own files

.gitignore

@@ -16,7 +16,8 @@ test/import
 pffi-define
 test/pffi-define
 size-of
-test/size-of
+test/*
+!test/*.scm
 retropikzel/pffi/*/*.c
 retropikzel/pffi/*/*.o*
 retropikzel/pffi/*/*.so

Makefile

@@ -36,7 +36,6 @@ clean:
 	rm -rf test/*.o*
 	rm -rf test/*.so
 	rm -rf test/*.meta
-	rm -rf test/import
 	rm -rf test/pffi-define
 	rm -rf test/*gambit*
 	rm -rf test/*.link
@@ -45,3 +44,4 @@ clean:
 	rm -rf *.so
 	rm -rf *.a
 	rm -rf tmp
+	find ./test -type f -not -name "*.scm" -exec bash -c "test -x {} && rm {}" \;

retropikzel/pffi/v0-1-0/chicken.scm

@@ -5,7 +5,8 @@
           (scheme file)
           (scheme process-context)
           (chicken foreign)
-          (chicken syntax))
+          (chicken syntax)
+          (chicken memory))
   (export pffi-shared-object-load
           pffi-define
           pffi-size-of
@@ -49,7 +50,7 @@
 
     (define pffi-pointer?
       (lambda (object)
-        (error "Not defined")))
+        (pointer? object)))
 
     (define-syntax pffi-define
       (er-macro-transformer
@@ -92,13 +93,34 @@
               `(define ,scheme-name
                  (foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
 
-    (define pffi-size-of
+    (define-syntax pffi-size-of
-      (lambda (type)
+      (er-macro-transformer
-        (error "Not defined")))
+        (lambda (expr rename compare)
+          (let ((type (car (cdr (car (cdr expr))))))
+            (cond ((equal? type 'int8) `(foreign-value "sizeof(int8_t)" int))
+                  ((equal? type 'uint8) `(foreign-value "sizeof(uint8_t)" int))
+                  ((equal? type 'int16) `(foreign-value "sizeof(int16_t)" int))
+                  ((equal? type 'uint16) `(foreign-value "sizeof(uint16_t)" int))
+                  ((equal? type 'int32) `(foreign-value "sizeof(int32_t)" int))
+                  ((equal? type 'uint32) `(foreign-value "sizeof(uint32_t)" int))
+                  ((equal? type 'int64) `(foreign-value "sizeof(int64_t)" int))
+                  ((equal? type 'uint64) `(foreign-value "sizeof(uint64_t)" int))
+                  ((equal? type 'char) `(foreign-value "sizeof(char)" int))
+                  ((equal? type 'unsigned-char) `(foreign-value "sizeof(unsigned char)" int))
+                  ((equal? type 'short) `(foreign-value "sizeof(short)" int))
+                  ((equal? type 'unsigned-short) `(foreign-value "sizeof(unsigned short)" int))
+                  ((equal? type 'int) `(foreign-value "sizeof(int)" int))
+                  ((equal? type 'unsigned-int) `(foreign-value "sizeof(unsigned int)" int))
+                  ((equal? type 'long) `(foreign-value "sizeof(long)" int))
+                  ((equal? type 'unsigned-long) `(foreign-value "sizeof(unsigned long)" int))
+                  ((equal? type 'float) `(foreign-value "sizeof(float)" int))
+                  ((equal? type 'double) `(foreign-value "sizeof(double)" int))
+                  ((equal? type 'pointer) `(foreign-value "sizeof(int)" int))
+                  (else `(error "pffi-size-of -- No such pffi type" type)))))))
 
     (define pffi-pointer-allocate
       (lambda (size)
-        (error "Not defined")))
+        (allocate size)))
 
     (define pffi-pointer-null
       (lambda ()
@@ -106,11 +128,21 @@
 
     (define pffi-string->pointer
       (lambda (string-content)
-        (error "Not defined")))
+        (let* ((size (string-length string-content))
+               (pointer (pffi-pointer-allocate size)))
+          (move-memory! string-content pointer size 0)
+          pointer)))
+
+    (pffi-define strlen #f 'strlen 'int (list 'pointer))
 
     (define pffi-pointer->string
       (lambda (pointer)
-        pointer))
+        (if (string? pointer)
+          pointer
+          (let* ((size (strlen pointer))
+                 (string-content (make-string size)))
+            (move-memory! pointer string-content size 0)
+            string-content))))
 
     (define pffi-pointer->bytevector
       (lambda (pointer size)
@@ -128,7 +160,7 @@
 
     (define pffi-pointer-free
       (lambda (pointer)
-        (error "Not defined")))
+        (free pointer)))
 
     (define pffi-pointer-null?
       (lambda (pointer)
@@ -136,12 +168,47 @@
 
     (define pffi-pointer-set!
       (lambda (pointer type offset value)
-        (let ((p pointer))
+        (cond
-          (error "Not defined"))))
+          ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
+          ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
+          ((equal? type 'int16) (pointer-s16-set! (pointer+ pointer offset) value))
+          ((equal? type 'uint16) (pointer-u16-set! (pointer+ pointer offset) value))
+          ((equal? type 'int32) (pointer-s32-set! (pointer+ pointer offset) value))
+          ((equal? type 'uint32) (pointer-u32-set! (pointer+ pointer offset) value))
+          ((equal? type 'int64) (pointer-s64-set! (pointer+ pointer offset) value))
+          ((equal? type 'uint64) (pointer-u64-set! (pointer+ pointer offset) value))
+          ((equal? type 'char) (pointer-s8-set! (pointer+ pointer offset) value))
+          ((equal? type 'short) (pointer-s8-set! (pointer+ pointer offset) value))
+          ((equal? type 'unsigned-short) (pointer-u8-set! (pointer+ pointer offset) value))
+          ((equal? type 'int) (pointer-s32-set! (pointer+ pointer offset) value))
+          ((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
+          ((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
+          ((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
+          ((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value))
+          ((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
+          ((equal? type 'pointer) (pointer-u32-set! (pointer+ pointer offset) value)))))
 
     (define pffi-pointer-get
       (lambda (pointer type offset)
-        (error "Not defined")))
+        (cond
+          ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
+          ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
+          ((equal? type 'int16) (pointer-s16-ref (pointer+ pointer offset)))
+          ((equal? type 'uint16) (pointer-u16-ref (pointer+ pointer offset)))
+          ((equal? type 'int32) (pointer-s32-ref (pointer+ pointer offset)))
+          ((equal? type 'uint32) (pointer-u32-ref (pointer+ pointer offset)))
+          ((equal? type 'int64) (pointer-s64-ref (pointer+ pointer offset)))
+          ((equal? type 'uint64) (pointer-u64-ref (pointer+ pointer offset)))
+          ((equal? type 'char) (pointer-s8-ref (pointer+ pointer offset)))
+          ((equal? type 'short) (pointer-s8-ref (pointer+ pointer offset)))
+          ((equal? type 'unsigned-short) (pointer-u8-ref (pointer+ pointer offset)))
+          ((equal? type 'int) (pointer-s32-ref (pointer+ pointer offset)))
+          ((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
+          ((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
+          ((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
+          ((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset)))
+          ((equal? type 'double) (pointer-s32-ref (pointer+ pointer offset)))
+          ((equal? type 'pointer) (pointer-u32-ref (pointer+ pointer offset))))))
 
     (define pffi-pointer-deref
       (lambda (pointer)

retropikzel/pffi/v0-1-0/sagittarius.scm

@@ -125,8 +125,6 @@
                 ((equal? type 'uint32) (pointer-set-c-uint32_t! p offset value))
                 ((equal? type 'int64) (pointer-set-c-int64_t! p offset value))
                 ((equal? type 'uint64) (pointer-set-c-uint64_t! p offset value))
-                ((equal? type 'intptr) (pointer-set-c-intptr_t! p offset value))
-                ((equal? type 'uintptr) (pointer-set-c-uintptr_t! p offset value))
                 ((equal? type 'char) (pointer-set-c-char! p offset value))
                 ((equal? type 'short) (pointer-set-c-short! p offset value))
                 ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! p offset value))
@@ -136,7 +134,7 @@
                 ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! p offset value))
                 ((equal? type 'float) (pointer-set-c-float! p offset value))
                 ((equal? type 'double) (pointer-set-c-double! p offset value))
-                ((equal? type 'void) (pointer-set-c-void*! p offset value))))))
+                ((equal? type 'void*) (pointer-set-c-void*! p offset value))))))
 
     (define pffi-pointer-get
       (lambda (pointer type offset)
@@ -150,8 +148,6 @@
                 ((equal? native-type 'uint32_t) (pointer-ref-c-uint32_t p offset))
                 ((equal? native-type 'int64_t) (pointer-ref-c-int64_t p offset))
                 ((equal? native-type 'uint64_t) (pointer-ref-c-uint64_t p offset))
-                ((equal? native-type 'intptr_t) (pointer-ref-c-intptr_t p offset))
-                ((equal? native-type 'uintptr_t) (pointer-ref-c-uintptr_t p offset))
                 ((equal? native-type 'char) (pointer-ref-c-char p offset))
                 ((equal? native-type 'short) (pointer-set-c-short p offset value))
                 ((equal? native-type 'unsigned-short) (pointer-ref-c-unsigned-short p offset))

scripts/test-runs-compilers.sh

@@ -1,6 +1,7 @@
 
-${SCHEME} ./test/import.scm
+for file in ./test/*.scm
-./test/import
+do
-
+    echo "Testing ${file}"
-${SCHEME} ./test/pffi-define.scm
+    ${SCHEME} ${file}
-./test/pffi-define
+    ${file//.scm/}
+done

scripts/test-runs-dynamic.sh

@@ -1,7 +1,6 @@
 
-${SCHEME} ./test/hello.scm
+for file in ./test/*.scm
-${SCHEME} ./test/import.scm
+do
-${SCHEME} ./test/size-of.scm
+    echo "Testing ${file}"
-${SCHEME} ./test/pointer-set-get.scm
+    ${SCHEME} ${file}
-${SCHEME} ./test/string-to-pointer-to-string.scm
+done
-${SCHEME} ./test/pffi-define.scm

test/39_pointer-allocate.scm

@@ -0,0 +1,14 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0-1-0 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)
+
+

test/400_pointer-allocate-free.scm

@@ -0,0 +1,14 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0-1-0 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)
+
+

test/401_is-pointer.scm

@@ -0,0 +1,12 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0-1-0 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"))
+
+

test/410_pointer-set-get.scm

@@ -18,11 +18,14 @@
 (write p)
 (newline)
 
-(write (pffi-pointer-get p
+(let ((result(pffi-pointer-get p
-                        'uint8
+                               'uint8
-                        (+ (* (pffi-size-of 'uint32))
+                               (+ (* (pffi-size-of 'uint32))
-                           (* (pffi-size-of 'uint8) 2))
+                                  (* (pffi-size-of 'uint8) 2)))))
-                        ))
+  (if (not (= result 42))
-(newline)
+    (error "pffi-pointer-get did not return 42"))
+
+  (write result)
+  (newline))
 
 

test/500_string-to-pointer-to-string.scm

@@ -0,0 +1,17 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0-1-0 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)
+
+

test/600_string-to_pointer_to_string.scm

@@ -0,0 +1,17 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0-1-0 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)
+
+

test/pffi-lambda.scm

@@ -1,11 +0,0 @@
-(import (scheme base)
-        (scheme write)
-        (retropikzel pffi v0.1.0 main))
-
-(define libcurl (pffi-shared-object-auto-load "curl" (list)))
-
-(define curl-version (pffi-lambda libcurl 'curl_version 'string (list)))
-
-
-(write (pffi-pointer->string (curl-version)))
-(newline)

test/sdl2.scm

@@ -1,32 +0,0 @@
-(import (scheme base)
-        (scheme write)
-        (scheme read)
-        (retropikzel pffi v0.1.0 main))
-
-
-(define sdl2 (pffi-shared-object-auto-load "SDL2" (list)))
-
-(pffi-call sdl2 'SDL_Init 'int '((int . 32)))
-
-(define window (pffi-call sdl2
-                          'SDL_CreateWindow
-                          'pointer
-                          (list (cons 'pointer (pffi-string->pointer "Testing pffi"))
-                                (cons 'int 1)
-                                (cons 'int 1)
-                                (cons 'int 400)
-                                (cons 'int 400)
-                                (cons 'int 4))))
-
-(define renderer (pffi-call sdl2
-                            'SDL_CreateRenderer
-                            'pointer
-                            (list (cons 'pointer window)
-                                  (cons 'int -1)
-                                  (cons 'int 2))))
-
-(pffi-call sdl2 'SDL_RenderClear 'int (list (cons 'pointer renderer)))
-(pffi-call sdl2 'SDL_RenderPresent 'int (list (cons 'pointer renderer)))
-
-(display (pffi-call sdl2 'SDL_Delay 'void '((int . 2000))))
-

test/string-to-pointer-to-string.scm

@@ -1,14 +0,0 @@
-(import (scheme base)
-        (scheme write)
-        (retropikzel pffi v0-1-0 main))
-
-
-(define p (pffi-string->pointer "Hello world"))
-(write p)
-(newline)
-
-(define s (pffi-pointer->string p))
-(write s)
-(newline)
-
-