;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 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
+(with-test-prefix "dynamic-pointer"
+
+ (pass-if-exception
+ "error message"
+ '(misc-error . "^Symbol not found")
+ (dynamic-func "does_not_exist___" (dynamic-link))))
+
+\f
(with-test-prefix "null pointer"
(pass-if "pointer?"
(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 (false-if-exception
+ (dynamic-func "scm_is_pair" (dynamic-link))))
+ (ptr (make-pointer 123)))
+ (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<->scm"
+
+ (pass-if "immediates"
+ (equal? (pointer->scm (scm->pointer #\newline))
+ #\newline))
+
+ (pass-if "non-immediates"
+ (equal? (pointer->scm (scm->pointer "Hello, world!"))
+ "Hello, world!")))
+
+\f
(define-wrapped-pointer-type foo
foo?
wrap-foo unwrap-foo
(pass-if "pointer from bits"
(let* ((bytes (iota (sizeof '*)))
- (bv (u8-list->bytevector bytes)))
+ (bv (u8-list->bytevector bytes))
+ (fold (case (native-endianness)
+ ((little) fold-right)
+ ((big) fold)
+ (else (error "unsupported endianness")))))
(= (pointer-address
(make-pointer (bytevector-uint-ref bv 0 (native-endianness)
(sizeof '*))))
- (fold-right (lambda (byte address)
- (+ byte (* 256 address)))
- 0
- bytes))))
+ (fold (lambda (byte address)
+ (+ byte (* 256 address)))
+ 0
+ bytes))))
(pass-if "dereference-pointer"
(let* ((bytes (iota (sizeof '*)))
- (bv (u8-list->bytevector bytes)))
+ (bv (u8-list->bytevector bytes))
+ (fold (case (native-endianness)
+ ((little) fold-right)
+ ((big) fold)
+ (else (error "unsupported endianness")))))
(= (pointer-address
(dereference-pointer (bytevector->pointer bv)))
- (fold-right (lambda (byte address)
- (+ byte (* 256 address)))
- 0
- bytes)))))
+ (fold (lambda (byte address)
+ (+ byte (* 256 address)))
+ 0
+ bytes)))))
\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)))))
(pass-if "bijection [latin1]"
(with-latin1-locale
(let ((s "Szép jó napot!"))
- (string=? s (pointer->string (string->pointer s)))))))
+ (string=? s (pointer->string (string->pointer s))))))
+
+ (pass-if "bijection, utf-8"
+ (let ((s "hello, world"))
+ (string=? s (pointer->string (string->pointer s "utf-8")
+ -1 "utf-8"))))
+
+ (pass-if "bijection, utf-8 [latin1]"
+ (let ((s "Szép jó napot!"))
+ (string=? s (pointer->string (string->pointer s "utf-8")
+ -1 "utf-8")))))
+
\f
(with-test-prefix "pointer->procedure"
(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)))
(arg3 (map (cut / <> 4.0) (iota 123 100 4))))
(equal? (map proc arg1 arg2 arg3)
(map proc* arg1 arg2 arg3)))
+ (throw 'unresolved)))
+
+ (pass-if "procedures returning a pointer"
+ (if (defined? 'procedure->pointer)
+ (let* ((called? #f)
+ (proc (lambda (i) (set! called? #t) (make-pointer i)))
+ (pointer (procedure->pointer '* proc (list int)))
+ (proc* (pointer->procedure '* pointer (list int)))
+ (result (proc* 777)))
+ (and called? (equal? result (make-pointer 777))))
+ (throw 'unresolved)))
+
+ (pass-if "procedures returning void"
+ (if (defined? 'procedure->pointer)
+ (let* ((called? #f)
+ (proc (lambda () (set! called? #t)))
+ (pointer (procedure->pointer void proc '()))
+ (proc* (pointer->procedure void pointer '())))
+ (proc*)
+ called?)
+ (throw 'unresolved)))
+
+ (pass-if "procedure is retained"
+ ;; The lambda passed to `procedure->pointer' must remain live.
+ (if (defined? 'procedure->pointer)
+ (let* ((ptr (procedure->pointer int
+ (lambda (x) (+ x 7))
+ (list int)))
+ (procs (unfold (cut >= <> 10000)
+ (lambda (i)
+ (pointer->procedure int ptr (list int)))
+ 1+
+ 0)))
+ (gc) (gc) (gc)
+ (every (cut = <> 9)
+ (map (lambda (f) (f 2)) procs)))
(throw 'unresolved))))
\f
(= (sizeof (list int8 double))
(+ (alignof double) (sizeof double))))
+ (pass-if "sizeof { double, int8 }"
+ (= (sizeof (list double int8))
+ (+ (alignof double) (sizeof double))))
+
(pass-if "sizeof { short, int, long, pointer }"
(let ((layout (list short int long '*)))
(>= (sizeof layout)
HCoop / bpt / guile.git / blobdiff