Adding boolean support

Author: ktakashi

src/pffi.sls

@@ -50,7 +50,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             size-of-unsigned-char
@@ -64,6 +64,7 @@
             size-of-float
             size-of-double
             size-of-pointer
+	    size-of-boolean
             size-of-int8_t
             size-of-int16_t
             size-of-int32_t

src/pffi/compat.chezscheme.sls

@@ -52,7 +52,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             ;; pointer ref
@@ -105,6 +105,7 @@
             size-of-float
             size-of-double
             size-of-pointer
+	    size-of-boolean
             (rename (size-of-int8 size-of-int8_t)
                     (size-of-int16 size-of-int16_t)
                     (size-of-int32 size-of-int32_t)
@@ -222,6 +223,7 @@
 (define-type-alias double         double)
 (define-type-alias float          float)
 (define-type-alias pointer        void*)
+(define-type-alias boolean        boolean)
 
 (define (open-shared-object path)
   (load-shared-object path)
@@ -390,6 +392,8 @@
 (define-deref uint64)
 (define-deref pointer make-integer-pointer pointer->integer)
 
+(define size-of-boolean (ftype-sizeof boolean))
+
 ;; Unlock objects that are referenced by the pool.
 (define (cleanup-bytevector-locks!)
   (do ((x (garbage-pool) (garbage-pool)))

src/pffi/compat.guile.sls

@@ -52,7 +52,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             ;; pointer ref
@@ -105,6 +105,7 @@
             size-of-float
             size-of-double
             size-of-pointer
+	    size-of-boolean
             size-of-int8_t
             size-of-int16_t
             size-of-int32_t
@@ -158,6 +159,7 @@
 (define-ftype int64_t        int64)
 (define-ftype uint64_t       uint64)
 (define-ftype pointer        '*)
+(define-ftype boolean        int8) ;; use int8 to make the size = 1
 (define ___            '___) ;; dummy
 
 (define (open-shared-object path)
@@ -175,21 +177,23 @@
   (cond ((ffi-type-descriptor? type) (ffi-type-descriptor-alias type))
 	(else type)))
 
-(define (make-c-function lib conv ffi:ret name ffi:arg-types)
-  (define arg-types (map ->native-type ffi:arg-types))
+(define (make-c-function lib conv ffi:ret name arg-types)
   (define ret (->native-type ffi:ret))
   (define (s->p s) (b->p (string->utf8 (string-append s "\x0;"))))
   (define (b->p bv) (bytevector->pointer bv))
   (define ptr (lookup-shared-object lib (symbol->string name)))
   (define (convert-arg type arg)
-    (case type
-      ((*)
-       (cond ((string? arg) (s->p arg))
-	     ((bytevector? arg) (b->p arg))
-	     ;; Let Guile complain, if not the proper
-	     ;; one
-	     (else arg)))
-      (else arg)))
+    (cond ((eq? type pointer)
+	   (cond ((string? arg)     (s->p arg))
+		 ((bytevector? arg) (b->p arg))
+		 ;; Let Guile complain, if not the proper
+		 ;; one
+		 (else arg)))
+	  ((eq? type boolean)
+	   (unless (boolean? arg)
+	     (assertion-violation name "Boolean is required" arg))
+	   (if arg 1 0))
+	  (else arg)))
   (define (arg->type arg)
     ;; it's a bit awkward but no other way
     (cond ((number? arg)
@@ -203,27 +207,31 @@
 		 ((real? arg) double)
 		 (else (assertion-violation name "Unsuported number" arg))))
 	  ((or (string? arg) (bytevector? arg) (pointer? arg)) pointer)
+	  ((boolean? arg) boolean)
 	  (else (assertion-violation name "Unsuported type" arg))))
-		   
+  (define (convert-ret type r)
+    (cond ((eq? type boolean) (eqv? r 1))
+	  (else r)))
   (cond ((memq ___ arg-types) =>
 	 (lambda (l)
 	   (unless (null? (cdr l))
-	     (assertion-violation
-	      'make-c-function
-	      "___ must be the last of argument type"
-	      arg-types))
+	     (assertion-violation 'make-c-function
+	      "___ must be the last of argument type" arg-types))
 	   (let ((required-args (remove (lambda (e) (eq? ___ e)) arg-types)))
 	     (lambda args*
 	       (let-values (((required rest)
 			     (split-at args* (- (length required-args) 1))))
 		 (let* ((real-arg-types (append (drop-right arg-types 1)
 						(map arg->type rest)))
-			(fp (pointer->procedure ret ptr real-arg-types)))
-		   (apply fp (map convert-arg real-arg-types args*))))))))
+			(fp (pointer->procedure ret ptr
+			     (map ->native-type real-arg-types))))
+		   (convert-ret ffi:ret
+		    (apply fp (map convert-arg real-arg-types args*)))))))))
 	(else
-	 (let ((fp (pointer->procedure ret ptr arg-types)))
+	 (let ((fp (pointer->procedure ret ptr (map ->native-type arg-types))))
 	   (lambda args*
-	     (apply fp (map convert-arg arg-types args*)))))))
+	     (convert-ret ffi:ret
+			  (apply fp (map convert-arg arg-types args*))))))))
 
 (define (make-c-callback ret args proc)
   (procedure->pointer (->native-type ret) proc (map ->native-type args)))
@@ -326,6 +334,7 @@
 (define-sizeof int16_t)
 (define-sizeof int32_t)
 (define-sizeof int64_t)
+(define-sizeof boolean)
 ;; for define-deref
 (define size-of-unsigned-char   size-of-char)
 (define size-of-unsigned-short  size-of-short)

src/pffi/compat.mzscheme.sls

@@ -53,7 +53,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             ;; pointer ref
@@ -105,6 +105,7 @@
             size-of-float
             size-of-double
             size-of-pointer
+	    size-of-boolean
             size-of-int8_t
             size-of-int16_t
             size-of-int32_t
@@ -152,6 +153,7 @@
 (define-ftype int64_t        _int64)
 (define-ftype uint64_t       _uint64)
 (define-ftype pointer        _pointer)
+(define-ftype boolean        _stdbool)
 (define ___            '___)
 
 ;; for convenience
@@ -372,6 +374,7 @@
 (define-sizeof int)
 (define-sizeof long)
 (define-sizeof pointer)
+(define-sizeof boolean)
 (define-sizeof float)
 (define-sizeof double)
 (define-sizeof int8_t)

src/pffi/compat.sagittarius.sls

@@ -52,7 +52,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             ;; pointer ref
@@ -113,7 +113,8 @@
             size-of-long
             size-of-float
             size-of-double
-            (rename (size-of-void* size-of-pointer))
+            (rename (size-of-void* size-of-pointer)
+		    (size-of-bool size-of-boolean))
             size-of-int8_t
             size-of-int16_t
             size-of-int32_t
@@ -199,5 +200,6 @@
 (define-ftype int64_t)
 (define-ftype uint64_t size-of-int64_t)
 (define pointer (make-ffi-type-descriptor 'pointer void* size-of-void*))
+(define boolean (make-ffi-type-descriptor 'boolean bool size-of-bool))
 
 )

src/pffi/procedure.sls

@@ -49,7 +49,7 @@
             int32_t uint32_t
             int64_t uint64_t
             pointer callback
-            void
+            void boolean
 	    ___
 
             size-of-char
@@ -59,6 +59,7 @@
             size-of-float
             size-of-double
             size-of-pointer
+	    size-of-boolean
             size-of-int8_t
             size-of-int16_t
             size-of-int32_t

tests/functions.c

@@ -101,5 +101,21 @@ void free_st_values(struct st2 *st)
   free(st->p.elements);
 }
 
+/* for boolean test */
+int is_even(int n) {
+  return n % 2 == 0;
+}
+
+int is_odd(int n) {
+  return n % 2 != 0;
+}
+
+int check_dispatch(int n, int check_even) {
+  if (check_even) {
+    return is_even(n);
+  } else {
+    return is_odd(n);
+  }
+}
 
 /* TODO more */

tests/test.scm

@@ -340,6 +340,19 @@
     (fields (ppp p)))
   (test-assert "make-st-ppp" (make-st-ppp (integer->pointer 0)))
   (test-assert "make-un-ppp" (make-un-ppp (integer->pointer 0))))
-  
+
+;; boolean type
+(let ((is-even? (foreign-procedure test-lib boolean is_even (int)))
+      (check-dispatch
+       (foreign-procedure test-lib boolean check_dispatch (int boolean))))
+  ;; (display size-of-boolean)
+  ;; We don't check the size of boolean here, as some use C99 bool
+  ;; and some, or Chez..., use just int
+  (test-assert "size-of-boolean" size-of-boolean)
+  (test-assert "is-even? (1)" (boolean? (is-even? 2)))
+  (test-assert "is-even? (2)" (not (is-even? 1)))
+  (test-assert "check-dispatch (1)" (check-dispatch 2 #t))
+  (test-assert "check-dispatch (2)" (not (check-dispatch 2 #f))))
+
 
 (test-end)