Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / test-suite / tests / foreign.test

diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 7c5ecd6..8ba989e 100644 (file)
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -1,6 +1,6 @@
 ;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -51,6 +51,10 @@
   (pass-if "null-pointer? %null-pointer"
     (null-pointer? %null-pointer))
 
+  (pass-if-exception "dereference-pointer %null-pointer"
+    exception:null-pointer-error
+    (dereference-pointer %null-pointer))
+
   (pass-if-exception "pointer->bytevector %null-pointer"
     exception:null-pointer-error
     (pointer->bytevector %null-pointer 7)))
@@ -68,15 +72,22 @@
     (equal? (make-pointer 123) (make-pointer 123)))
 
   (pass-if "equal? modulo finalizer"
-    (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
-      (equal? (make-pointer 123)
-              (make-pointer 123 finalizer))))
+    (let ((finalizer (false-if-exception
+                      (dynamic-func "scm_is_pair" (dynamic-link)))))
+      (if (not finalizer)
+          (throw 'unresolved)               ;  Windows or a static build
+          (equal? (make-pointer 123)
+                  (make-pointer 123 finalizer)))))
 
   (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
-    (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
+    (let ((finalizer (false-if-exception
+                      (dynamic-func "scm_is_pair" (dynamic-link))))
           (ptr       (make-pointer 123)))
-      (set-pointer-finalizer! ptr finalizer)
-      (equal? (make-pointer 123) ptr)))
+      (if (not finalizer)
+          (throw 'unresolved)                ; Windows or a static build
+          (begin
+            (set-pointer-finalizer! ptr finalizer)
+            (equal? (make-pointer 123) ptr)))))
 
   (pass-if "not equal?"
     (not (equal? (make-pointer 123) (make-pointer 456)))))
@@ -217,9 +228,13 @@
 
   (define qsort
     ;; Bindings for libc's `qsort' function.
-    (pointer->procedure void
-                        (dynamic-func "qsort" (dynamic-link))
-                        (list '* size_t size_t '*)))
+    ;; On some platforms, such as MinGW, `qsort' is visible only if
+    ;; linking with `-export-dynamic'.  Just skip these tests when it's
+    ;; not visible.
+    (false-if-exception
+     (pointer->procedure void
+                         (dynamic-func "qsort" (dynamic-link))
+                         (list '* size_t size_t '*))))
 
   (define (dereference-pointer-to-byte ptr)
     (let ((b (pointer->bytevector ptr 1)))
@@ -229,7 +244,7 @@
     '(7 1 127 3 5 4 77 2 9 0))
 
   (pass-if "qsort"
-    (if (defined? 'procedure->pointer)
+    (if (and qsort (defined? 'procedure->pointer))
         (let* ((called? #f)
                (cmp     (lambda (x y)
                           (set! called? #t)
@@ -247,7 +262,7 @@
   (pass-if-exception "qsort, wrong return type"
     exception:wrong-type-arg
 
-    (if (defined? 'procedure->pointer)
+    (if (and qsort (defined? 'procedure->pointer))
         (let* ((cmp     (lambda (x y) #f)) ; wrong return type
                (ptr     (procedure->pointer int cmp (list '* '*)))
                (bv      (u8-list->bytevector input)))
@@ -259,7 +274,7 @@
   (pass-if-exception "qsort, wrong arity"
     exception:wrong-num-args
 
-    (if (defined? 'procedure->pointer)
+    (if (and qsort (defined? 'procedure->pointer))
         (let* ((cmp     (lambda (x y z) #f)) ; wrong arity
                (ptr     (procedure->pointer int cmp (list '* '*)))
                (bv      (u8-list->bytevector input)))