Much more passing tests

tests/addressof.scm

@@ -88,8 +88,6 @@
                       '(pointer pointer))
 
 (define input-pointer (make-c-bytevector (c-size-of 'int)))
-(debug (c-bytevector->address input-pointer))
-(assert equal? (number? (c-bytevector->address input-pointer)) #t)
 (c-bytevector-s32-native-set! input-pointer 0 100)
 (assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 100) #t)
 (debug (c-bytevector-s32-native-ref input-pointer 0))

tests/callback.scm

@@ -0,0 +1,128 @@
+(import (scheme base)
+        (scheme write)
+        (scheme char)
+        (scheme file)
+        (scheme process-context)
+        (foreign c))
+
+;; util
+(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)))
+
+(cond-expand
+  (gambit
+    (define assert
+      (lambda (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))))))
+  (else
+    (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)))))
+
+
+;; define-c-library
+
+(print-header 'define-c-library)
+
+(cond-expand
+  (windows (define-c-library libc
+                                '("stdio.h" "string.h")
+                                "ucrtbase"
+                                '((additional-versions ("0" "6")))))
+  (else (define-c-library libc
+                             '("stdio.h" "string.h")
+                             "c"
+                             '((additional-versions ("0" "6"))))))
+
+(debug libc)
+
+;; define-c-callback
+
+(print-header 'define-c-callback)
+
+(define array (make-c-bytevector (* (c-size-of 'int) 3)))
+(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3)
+(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
+(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
+
+(define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
+
+(define-c-callback compare
+                   'int
+                   '(pointer pointer)
+                   (lambda (pointer-a pointer-b)
+                     (let ((a (c-bytevector-s32-native-ref pointer-a 0))
+                           (b (c-bytevector-s32-native-ref pointer-b 0)))
+                       (cond ((> a b) 1)
+                             ((= a b) 0)
+                             ((< a b) -1)))))
+(write compare)
+(newline)
+
+(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
+                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
+                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
+(debug unsorted)
+(assert equal? unsorted (list 3 2 1))
+
+(qsort array 3 (c-size-of 'int) compare)
+
+(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
+                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
+                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
+(debug sorted)
+(assert equal? sorted (list 1 2 3))
+
+(exit 0)

tests/primitives.scm

@@ -279,6 +279,19 @@
 (debug (c-bytevector-u8-ref u8-pointer 0))
 (assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t)
 
+;; c-bytevector-pointer-set! and c-bytevector-pointer-ref
+(print-header "c-bytevector-pointer-set! and c-bytevector-pointer-ref")
+
+(define p-pointer (make-c-bytevector (c-size-of 'pointer)))
+(debug p-pointer)
+(debug (c-bytevector? p-pointer))
+(assert equal? (c-bytevector? p-pointer) #t)
+(c-bytevector-pointer-set! p-pointer 0 u8-pointer)
+(debug p-pointer)
+(debug (c-bytevector-pointer-ref p-pointer 0))
+(debug (c-bytevector-u8-ref (c-bytevector-pointer-ref p-pointer 0) 0))
+(assert equal? (= (c-bytevector-u8-ref (c-bytevector-pointer-ref p-pointer 0) 0) 42) #t)
+
 ;; string->-utf8 c-utf8->string
 (print-header "string->c-utf8 c-utf8->string")
 (for-each
@@ -333,41 +346,4 @@
                                                (lambda () (read-line)))
                          "Hello world") #t)
 
-;; define-c-callback
-
-(print-header 'define-c-callback)
-
-(define array (make-c-bytevector (* (c-size-of 'int) 3)))
-(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3)
-(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2)
-(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1)
-
-(define-c-procedure qsort libc 'qsort 'void '(pointer int int callback))
-
-(define-c-callback compare
-                   'int
-                   '(pointer pointer)
-                   (lambda (pointer-a pointer-b)
-                     (let ((a (c-bytevector-s32-native-ref pointer-a 0))
-                           (b (c-bytevector-s32-native-ref pointer-b 0)))
-                       (cond ((> a b) 1)
-                             ((= a b) 0)
-                             ((< a b) -1)))))
-(write compare)
-(newline)
-
-(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
-                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
-                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
-(debug unsorted)
-(assert equal? unsorted (list 3 2 1))
-
-(qsort array 3 (c-size-of 'int) compare)
-
-(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0))
-                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1))
-                       (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2))))
-(debug sorted)
-(assert equal? sorted (list 1 2 3))
-
 (exit 0)