diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/standalone/Makefile.am | 11 | ||||
-rw-r--r-- | test-suite/standalone/test-foreign-object-c.c | 115 | ||||
-rwxr-xr-x | test-suite/standalone/test-foreign-object-scm | 119 | ||||
-rw-r--r-- | test-suite/tests/goops.test | 43 |
4 files changed, 284 insertions, 4 deletions
diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index fa77925d9..ce5f36959 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -129,6 +129,17 @@ TESTS += test-ffi endif HAVE_SHARED_LIBRARIES +# test-foreign-object-scm +check_SCRIPTS += test-foreign-object-scm +TESTS += test-foreign-object-scm + +# test-foreign-object-c +test_foreign_object_c_SOURCES = test-foreign-object-c.c +test_foreign_object_c_CFLAGS = ${test_cflags} +test_foreign_object_c_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-foreign-object-c +TESTS += test-foreign-object-c + # test-list test_list_SOURCES = test-list.c test_list_CFLAGS = ${test_cflags} diff --git a/test-suite/standalone/test-foreign-object-c.c b/test-suite/standalone/test-foreign-object-c.c new file mode 100644 index 000000000..613c1f631 --- /dev/null +++ b/test-suite/standalone/test-foreign-object-c.c @@ -0,0 +1,115 @@ +/* test-foreign-object-c.c - exercise C foreign object interface */ + +/* Copyright (C) 2014 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 + */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +enum + { + CSTR_SLOT_ADDR, + CSTR_SLOT_LEN, + CSTR_SLOT_COUNT + }; + +static void +finalizer (SCM obj) +{ + free (scm_foreign_object_ref (obj, CSTR_SLOT_ADDR)); +} + +static SCM +make_cstr_from_static (SCM type, const char *str) +{ + char *ours = strdup (str); + + if (!ours) + abort (); + + return scm_make_foreign_object_2 (type, ours, (void *) strlen (ours)); +} + +static int +cstr_equals_static_p (SCM cstr, const char *str) +{ + const char *addr; + size_t len; + + addr = scm_foreign_object_ref (cstr, CSTR_SLOT_ADDR); + len = scm_foreign_object_unsigned_ref (cstr, CSTR_SLOT_LEN); + + if (strlen (str) != len) + return 0; + + return strncmp (addr, str, len) == 0; +} + +static void +test_scm_foreign_object (void) +{ + SCM type_name, slot_names, type, cstr; + + type_name = scm_from_utf8_symbol ("<cstr>"); + slot_names = scm_list_2 (scm_from_utf8_symbol ("addr"), + scm_from_utf8_symbol ("len")); + type = scm_make_foreign_object_type (type_name, slot_names, finalizer); + + cstr = make_cstr_from_static (type, "Hello, world!"); + scm_assert_foreign_object_type (type, cstr); + + if (!cstr_equals_static_p (cstr, "Hello, world!")) + { + fprintf (stderr, "fail: test-foreign-object 1\n"); + exit (EXIT_FAILURE); + } + + { + int i; + for (i = 0; i < 5000; i++) + cstr = make_cstr_from_static (type, "Hello, world!"); + cstr = SCM_BOOL_F; + } + + scm_gc (); + scm_gc (); + scm_gc (); + + /* Allow time for the finalizer thread to run. */ + scm_usleep (scm_from_uint (50 * 1000)); +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_foreign_object (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-foreign-object-scm b/test-suite/standalone/test-foreign-object-scm new file mode 100755 index 000000000..7e4bd85d8 --- /dev/null +++ b/test-suite/standalone/test-foreign-object-scm @@ -0,0 +1,119 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# +;;; test-foreign-object-scm --- Foreign object interface. -*- Scheme -*- +;;; +;;; Copyright (C) 2014 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 + +(use-modules (system foreign) + (system foreign-object) + (rnrs bytevectors) + (oop goops)) + +(define (libc-ptr name) + (catch #t + (lambda () (dynamic-pointer name (dynamic-link))) + (lambda (k . args) + (print-exception (current-error-port) #f k args) + (write "Skipping test.\n" (current-error-port)) + (exit 0)))) + +(define malloc (pointer->procedure '* (libc-ptr "malloc") (list size_t))) +(define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '* size_t))) +(define free (pointer->procedure void (libc-ptr "free") '(*))) + +(define (finalize-cstr cstr) + (free (make-pointer (addr cstr)))) + +(define-foreign-object-type <cstr> make-cstr (addr len) + #:finalizer finalize-cstr) + +(define (cstr->string cstr) + (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8")) + +(define* (string->cstr str #:optional (k make-cstr)) + (let* ((bv (string->utf8 str)) + (len (bytevector-length bv)) + (mem (malloc len))) + (when (null-pointer? mem) + (error "Out of memory.")) + (memcpy mem (bytevector->pointer bv) len) + (k (pointer-address mem) len))) + +(define-method (write (cstr <cstr>) port) + (format port "<<cstr> ~s>" (cstr->string cstr))) + +(define-method (display (cstr <cstr>) port) + (display (cstr->string cstr) port)) + +(define-method (+ (a <cstr>) (b <cstr>)) + (string->cstr (string-append (cstr->string a) (cstr->string b)))) + +(define-method (equal? (a <cstr>) (b <cstr>)) + (equal? (cstr->string a) (cstr->string b))) + +(define failed? #f) +(define-syntax test + (syntax-rules () + ((_ exp res) + (let ((expected res) + (actual exp)) + (if (not (equal? actual expected)) + (begin + (set! failed? #t) + (format (current-error-port) + "bad return from expression `~a': expected ~A; got ~A~%" + 'exp expected actual))))))) + +(test (string->cstr "Hello, world!") + (+ (string->cstr "Hello, ") (string->cstr "world!"))) + +;; GOOPS construction syntax instead of make-cstr. +(test (string->cstr "Hello, world!") + (string->cstr "Hello, world!" + (lambda (addr len) + (make <cstr> #:addr addr #:len len)))) + +;; Subclassing. +(define-class <wrapped-cstr> (<cstr>) + (wrapped-string #:init-keyword #:wrapped-string + #:getter wrapped-string + #:init-form (error "missing #:wrapped-string"))) + +(define (string->wrapped-cstr string) + (string->cstr string (lambda (addr len) + (make <wrapped-cstr> #:addr addr #:len len + #:wrapped-string string)))) + +(let ((wrapped-cstr (string->wrapped-cstr "Hello, world!"))) + ;; Tests that <cst> methods work on <wrapped-cstr>. + (test "Hello, world!" (cstr->string wrapped-cstr)) + ;; Test the additional #:wrapped-string slot. + (test "Hello, world!" (wrapped-string wrapped-cstr))) + +(gc) (gc) (gc) + +;; Sleep 50 milliseconds to allow the finalization thread to run. +(usleep #e50e3) + +;; But we don't really know if it ran. Oh well. + +(exit (if failed? 1 0)) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 1705ee811..d8a5ecfad 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -1,6 +1,6 @@ ;;;; goops.test --- test suite for GOOPS -*- scheme -*- ;;;; -;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2001,2003,2004, 2006, 2008, 2009, 2011, 2012, 2014 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 @@ -474,9 +474,9 @@ (x bar) (set! (x bar) 2) (equal? (reverse z) - '(before-ref before-set! 1 before-ref after-ref - after-set! 1 1 before-ref after-ref - before-set! 2 before-ref after-ref after-set! 2 2))) + '(before-set! 1 before-ref after-ref + after-set! 1 1 before-ref after-ref + before-set! 2 before-ref after-ref after-set! 2 2))) (current-module)))) (use-modules (oop goops composite-slot)) @@ -527,3 +527,38 @@ exception:no-applicable-method (eval '(quxy 1) (current-module)))) + +(with-test-prefix "foreign slots" + (define-class <foreign-test> () + (a #:init-keyword #:a #:class <foreign-slot> + #:accessor test-a) + (b #:init-keyword #:b #:init-form 3 #:class <foreign-slot> + #:accessor test-b)) + + (pass-if-equal "constructing, no initargs" + '(0 3) + (let ((x (make <foreign-test>))) + (list (slot-ref x 'a) + (slot-ref x 'b)))) + + (pass-if-equal "constructing, initargs" + '(1 2) + (let ((x (make <foreign-test> #:a 1 #:b 2))) + (list (slot-ref x 'a) + (slot-ref x 'b)))) + + (pass-if-equal "getters" + '(0 3) + (let ((x (make <foreign-test>))) + (list (test-a x) (test-b x)))) + + (pass-if-equal "setters" + '(10 20) + (let ((x (make <foreign-test>))) + (set! (test-a x) 10) + (set! (test-b x) 20) + (list (test-a x) (test-b x)))) + + (pass-if-exception "out of range" + exception:out-of-range + (make <foreign-test> #:a (ash 1 64)))) |