diff options
Diffstat (limited to 'test-suite/tests/foreign.test')
-rw-r--r-- | test-suite/tests/foreign.test | 421 |
1 files changed, 421 insertions, 0 deletions
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test new file mode 100644 index 000000000..67b5c3790 --- /dev/null +++ b/test-suite/tests/foreign.test @@ -0,0 +1,421 @@ +;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2017 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; +;;; See also ../standalone/test-ffi for FFI tests. +;;; + +(define-module (test-foreign) + #:use-module (system foreign) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 format) + #:use-module (test-suite lib)) + + +(with-test-prefix "dynamic-pointer" + + (pass-if-exception + "error message" + '(misc-error . "^Symbol not found") + (dynamic-func "does_not_exist___" (dynamic-link)))) + + +(with-test-prefix "null pointer" + + (pass-if "pointer?" + (pointer? %null-pointer)) + + (pass-if "zero" + (= 0 (pointer-address %null-pointer))) + + (pass-if "null pointer identity" + (eq? %null-pointer (make-pointer 0))) + + (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))) + + +(with-test-prefix "make-pointer" + + (pass-if "pointer?" + (pointer? (make-pointer 123))) + + (pass-if "address preserved" + (= 123 (pointer-address (make-pointer 123)))) + + (pass-if "equal?" + (equal? (make-pointer 123) (make-pointer 123))) + + (pass-if "equal? modulo 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))))) + + +(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!"))) + + +(define-wrapped-pointer-type foo + foo? + wrap-foo unwrap-foo + (lambda (x p) + (format p "#<foo! ~a>" (pointer-address (unwrap-foo x))))) + +(with-test-prefix "define-wrapped-pointer-type" + + (pass-if "foo?" + (foo? (wrap-foo %null-pointer))) + + (pass-if "unwrap-foo" + (let ((p (make-pointer 123))) + (eq? p (unwrap-foo (wrap-foo p))))) + + (pass-if "identity" + (let ((p1 (make-pointer 123)) + (p2 (make-pointer 123))) + (eq? (wrap-foo p1) + (wrap-foo p2)))) + + (pass-if "printer" + (string=? "#<foo! 123>" + (with-output-to-string + (lambda () + (write (wrap-foo (make-pointer 123)))))))) + + +(with-test-prefix "pointer<->bytevector" + + (pass-if "bijection" + (let ((bv #vu8(0 1 2 3 4 5 6 7))) + (equal? (pointer->bytevector (bytevector->pointer bv) + (bytevector-length bv)) + bv))) + + (pass-if "pointer from bits" + (let* ((bytes (iota (sizeof '*))) + (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 (lambda (byte address) + (+ byte (* 256 address))) + 0 + bytes)))) + + (pass-if "dereference-pointer" + (let* ((bytes (iota (sizeof '*))) + (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 (lambda (byte address) + (+ byte (* 256 address))) + 0 + bytes))))) + + +(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)))))) + + (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"))))) + + + +(with-test-prefix "pointer->procedure" + + (pass-if-exception "object instead of pointer" + exception:wrong-type-arg + (let ((p (pointer->procedure '* %null-pointer '(*)))) + (p #t)))) + + +(with-test-prefix "procedure->pointer" + + (define qsort + ;; Bindings for libc's `qsort' function. + ;; 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" + (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, dynamic-link does + ;; not search recursively into + ;; linked DLLs. Thus, one needs + ;; to link to the core C + ;; library DLL explicitly. + (dynamic-link "cygwin1")) + (else + (dynamic-link)))) + (list '* size_t size_t '*)))) + + (define (dereference-pointer-to-byte ptr) + (let ((b (pointer->bytevector ptr 1))) + (bytevector-u8-ref b 0))) + + (define input + '(7 1 127 3 5 4 77 2 9 0)) + + (pass-if "qsort" + (if (and qsort (defined? 'procedure->pointer)) + (let* ((called? #f) + (cmp (lambda (x y) + (set! called? #t) + (- (dereference-pointer-to-byte x) + (dereference-pointer-to-byte y)))) + (ptr (procedure->pointer int cmp (list '* '*))) + (bv (u8-list->bytevector input))) + (qsort (bytevector->pointer bv) (bytevector-length bv) 1 + (procedure->pointer int cmp (list '* '*))) + (and called? + (equal? (bytevector->u8-list bv) + (sort input <)))) + (throw 'unresolved))) + + (pass-if-exception "qsort, wrong return type" + exception:wrong-type-arg + + (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))) + (qsort (bytevector->pointer bv) (bytevector-length bv) 1 + (procedure->pointer int cmp (list '* '*))) + #f) + (throw 'unresolved))) + + (pass-if-exception "qsort, wrong arity" + exception:wrong-num-args + + (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))) + (qsort (bytevector->pointer bv) (bytevector-length bv) 1 + (procedure->pointer int cmp (list '* '*))) + #f) + (throw 'unresolved))) + + (pass-if "bijection" + (if (defined? 'procedure->pointer) + (let* ((proc (lambda (x y z) + (+ x y z 0.0))) + (ret double) + (args (list float int16 double)) + (proc* (pointer->procedure ret + (procedure->pointer ret proc args) + args)) + (arg1 (map (cut / <> 2.0) (iota 123))) + (arg2 (iota 123 32000)) + (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))) + + (pass-if "arity" + (if (and qsort (defined? 'procedure->pointer)) + (equal? '(4 0 #f) (procedure-minimum-arity qsort)) + (throw 'unresolved)))) + + +(with-test-prefix "structs" + + (pass-if "sizeof { int8, double }" + (= (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) + (reduce + 0.0 (map sizeof layout))))) + + (pass-if "alignof { int8, double, int8 }" + ;; alignment of the most strictly aligned component + (let ((layout (list int8 double int8))) + (= (alignof layout) (alignof double)))) + + (pass-if "parse-c-struct" + (let ((layout (list int64 uint8)) + (data (list -300 43))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "alignment constraints honored" + (let ((layout (list int8 double)) + (data (list -7 3.14))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "int8, pointer" + (let ((layout (list uint8 '*)) + (data (list 222 (make-pointer 7777)))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "unsigned-long, int8, size_t" + (let ((layout (list unsigned-long int8 size_t)) + (data (list (expt 2 17) -128 (expt 2 18)))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "long, int, pointer" + (let ((layout (list long int '*)) + (data (list (- (expt 2 17)) -222 (make-pointer 777)))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "int8, pointer, short, double" + (let ((layout (list int8 '* short double)) + (data (list 77 %null-pointer -42 3.14))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data))) + + (pass-if "int8, { int8, double, int8 }, int16" + (let ((layout (list int8 (list int8 double int8) int16)) + (data (list 77 (list 42 4.2 55) 88))) + (equal? (parse-c-struct (make-c-struct layout data) + layout) + data)))) |