;;;; 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
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:use-module (test-suite lib))
\f
(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)))
(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)))))
\f
(with-test-prefix "pointer<->string"
+ (pass-if-exception "%default-port-conversion-strategy is error"
+ exception:encoding-error
+ (let ((s "χαοσ"))
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (string->pointer s "ISO-8859-1"))))
+
+ (pass-if "%default-port-conversion-strategy is escape"
+ (let ((s "teĥniko"))
+ (equal? (with-fluids ((%default-port-conversion-strategy 'escape))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ (format #f "te\\u~4,'0xniko"
+ (char->integer #\ĥ)))))
+
+ (pass-if "%default-port-conversion-strategy is substitute"
+ (let ((s "teĥniko")
+ (member (negate (negate member))))
+ (member (with-fluids ((%default-port-conversion-strategy 'substitute))
+ (pointer->string (string->pointer s "ISO-8859-1")))
+ '("te?niko"
+
+ ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0.
+ "te^hniko"))))
+
(pass-if "bijection"
(let ((s "hello, world"))
(string=? s (pointer->string (string->pointer s)))))
(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)))
'(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)
(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)))
(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)))