Handling with new feature of Sagittarius

Author: ktakashi

src/pffi/compat.sagittarius.sls

@@ -155,58 +155,73 @@
 		    (int64_t        ffi:int64_t)
 		    (uint64_t       ffi:uint64_t)
 		    (wchar_t        ffi:wchar_t)
-		    (pointer-ref-c-wchar ffi:pointer-ref-c-wchar ffi:)
+		    (pointer-ref-c-wchar  ffi:pointer-ref-c-wchar)
 		    (pointer-set-c-wchar! ffi:pointer-set-c-wchar!))
             (pffi ffi-type-descriptor)
 	    (srfi :1))
 
-(define (->native-type type)
-  (cond ((ffi-type-descriptor? type)
-	 (let ((alias (ffi-type-descriptor-alias type)))
-	   (if (eq? alias ffi:wchar_t)
-	       (case size-of-wchar_t
-		 ((2) ffi:uint16_t)
-		 ((4) ffi:uint32_t))
-	       alias)))
-	(else type)))
+(cond-expand
+ ;; proper wchar_t support is from 0.9.13
+ ((and cond-expand.version (version (>= "0.9.13")))
+  (define (->native-type type)
+    (cond ((ffi-type-descriptor? type) (ffi-type-descriptor-alias type))
+	  (else type)))
+  (define (make-c-function lib conv ret name args)
+    (%make-c-function lib (->native-type ret) name (map ->native-type args)))
+  
+  (define (make-c-callback ret args proc)
+    (%make-c-callback (->native-type ret) (map ->native-type args) proc))
+  )
+ ;; other versions must have workaround
+ (else
+  (define (->native-type type)
+    (cond ((ffi-type-descriptor? type)
+	   (let ((alias (ffi-type-descriptor-alias type)))
+	     (if (eq? alias ffi:wchar_t)
+		 (case size-of-wchar_t
+		   ((2) ffi:uint16_t)
+		   ((4) ffi:uint32_t))
+		 alias)))
+	  (else type)))
 
-(define (convert-arg type arg)
-  (cond ((ffi-type-descriptor? type)
-	 (let ((alias (ffi-type-descriptor-alias type)))
-	   (if (eq? alias ffi:wchar_t)
-	       (char->integer arg)
-	       arg)))
-	((eq? type ffi:wchar_t) (char->integer arg))
-	(else arg)))
-(define (convert-arg/guess arg)
-  (if (char? arg)
-      (char->integer arg)
-      arg))
-(define (convert-ret type r)
-  (cond ((ffi-type-descriptor? type)
-	 (let ((alias (ffi-type-descriptor-alias type)))
-	   (if (eq? alias ffi:wchar_t)
-	       (integer->char r)
-	       r)))
-	((eq? type ffi:wchar_t) (integer->char r))
-	(else r)))
-(define (make-c-function lib conv ret name args)
-  (let ((proc (%make-c-function lib (->native-type ret) name
-				(map ->native-type args))))
-    (if (memq '___ args)
-	(lambda formal
-	  (let ((n (- (length args) 1)))
-	    (let-values (((req opts) (split-at formal n)))
-	      (convert-ret ret
-		(apply proc (append! (map convert-arg args req)
-				     (map convert-arg/guess opts)))))))
-	(lambda formal
-	  (convert-ret ret (apply proc (map convert-arg args formal)))))))
+  (define (convert-arg type arg)
+    (cond ((ffi-type-descriptor? type)
+	   (let ((alias (ffi-type-descriptor-alias type)))
+	     (if (eq? alias ffi:wchar_t)
+		 (char->integer arg)
+		 arg)))
+	  ((eq? type ffi:wchar_t) (char->integer arg))
+	  (else arg)))
+  (define (convert-arg/guess arg)
+    (if (char? arg)
+	(char->integer arg)
+	arg))
+  (define (convert-ret type r)
+    (cond ((ffi-type-descriptor? type)
+	   (let ((alias (ffi-type-descriptor-alias type)))
+	     (if (eq? alias ffi:wchar_t)
+		 (integer->char r)
+		 r)))
+	  ((eq? type ffi:wchar_t) (integer->char r))
+	  (else r)))
+  (define (make-c-function lib conv ret name args)
+    (let ((proc (%make-c-function lib (->native-type ret) name
+				  (map ->native-type args))))
+      (if (memq '___ args)
+	  (lambda formal
+	    (let ((n (- (length args) 1)))
+	      (let-values (((req opts) (split-at formal n)))
+		(convert-ret ret
+		 (apply proc (append! (map convert-arg args req)
+				      (map convert-arg/guess opts)))))))
+	  (lambda formal
+	    (convert-ret ret (apply proc (map convert-arg args formal)))))))
 
-(define (make-c-callback ret args proc)
-  (define (wrapped . args*)
-    (convert-arg ret (apply proc (map convert-ret args args*))))
-  (%make-c-callback (->native-type ret) (map ->native-type args) wrapped))
+  (define (make-c-callback ret args proc)
+    (define (wrapped . args*)
+      (convert-arg ret (apply proc (map convert-ret args args*))))
+    (%make-c-callback (->native-type ret) (map ->native-type args) wrapped))
+  ))
 
 (define-syntax callback
   (syntax-rules ()