diff options
Diffstat (limited to 'test-suite/standalone')
51 files changed, 5481 insertions, 0 deletions
diff --git a/test-suite/standalone/.gitignore b/test-suite/standalone/.gitignore new file mode 100644 index 000000000..794146e60 --- /dev/null +++ b/test-suite/standalone/.gitignore @@ -0,0 +1,15 @@ +/test-conversion +/test-gh +/test-list +/test-num2integral +/test-round +/test-unwind +/test-with-guile-module +/test-use-srfi +/test-scm-with-guile +/test-scm-c-read +/test-fast-slot-ref +/test-scm-take-locale-symbol +/test-scm-take-u8vector +/test-loose-ends +/test-srfi-1 diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am new file mode 100644 index 000000000..2aba708da --- /dev/null +++ b/test-suite/standalone/Makefile.am @@ -0,0 +1,301 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, +## 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE 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, or +## (at your option) any later version. +## +## GUILE 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 GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +include $(top_srcdir)/am/snarf + +# initializations so we can use += below. +TESTS = +noinst_LTLIBRARIES = +check_PROGRAMS = +check_SCRIPTS = +BUILT_SOURCES = +EXTRA_DIST = + +TESTS_ENVIRONMENT = \ + top_srcdir="$(top_srcdir)" \ + srcdir="$(srcdir)" \ + builddir="$(builddir)" \ + @LOCALCHARSET_TESTS_ENVIRONMENT@ \ + GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/build-env" + +## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which +## may point us to an old, installed version of guile. +AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \ + -I$(top_srcdir)/lib -I$(top_builddir)/lib + +test_cflags = \ + -I$(top_srcdir)/test-suite/standalone -I. \ + $(EXTRA_DEFS) $(GUILE_CFLAGS) $(GCC_CFLAGS) + +AM_LDFLAGS = $(GUILE_CFLAGS) + +# How to link with libguile (same as `Libs' in `guile-2.0.pc'.) +LIBGUILE_LDADD = \ + ${top_builddir}/libguile/libguile-@GUILE_EFFECTIVE_VERSION@.la \ + $(BDW_GC_LIBS) + + +snarfcppopts = \ + -I$(top_srcdir) -I$(top_srcdir)/lib -I$(top_builddir)/lib -I$(top_builddir) \ + -I. $(DEFS) $(DEFAULT_INCLUDES) $(CPPFLAGS) $(CFLAGS) + +SUFFIXES = .x +.c.x: + $(AM_V_SNARF)$(GUILE_SNARF) -o $@ $< $(snarfcppopts) + +CLEANFILES = *.x + +.DELETE_ON_ERROR: + +check_SCRIPTS += test-system-cmds +TESTS += test-system-cmds + +check_SCRIPTS += test-bad-identifiers +TESTS += test-bad-identifiers + +check_SCRIPTS += test-require-extension +TESTS += test-require-extension + +check_SCRIPTS += test-guile-snarf +TESTS += test-guile-snarf + +check_SCRIPTS += test-import-order +TESTS += test-import-order +EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \ + test-import-order-c.scm test-import-order-d.scm + +check_SCRIPTS += test-command-line-encoding +TESTS += test-command-line-encoding + +check_SCRIPTS += test-command-line-encoding2 +TESTS += test-command-line-encoding2 + +check_SCRIPTS += test-language +TESTS += test-language +EXTRA_DIST += test-language.el test-language.js + +check_SCRIPTS += test-guild-compile +TESTS += test-guild-compile + +# test-num2integral +test_num2integral_SOURCES = test-num2integral.c +test_num2integral_CFLAGS = ${test_cflags} +test_num2integral_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-num2integral +TESTS += test-num2integral + +# test-round +test_round_CFLAGS = ${test_cflags} +test_round_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-round +TESTS += test-round + +if HAVE_SHARED_LIBRARIES + +# test-asmobs +noinst_LTLIBRARIES += libtest-asmobs.la +libtest_asmobs_la_SOURCES = test-asmobs-lib.c +libtest_asmobs_la_CFLAGS = ${test_cflags} +libtest_asmobs_la_LDFLAGS = -module -no-undefined -rpath `pwd` # so libtool will really build an .so +libtest_asmobs_la_LIBADD = $(LIBGUILE_LDADD) +BUILT_SOURCES += test-asmobs-lib.x +check_SCRIPTS += test-asmobs +TESTS += test-asmobs + +# test-ffi +noinst_LTLIBRARIES += libtest-ffi.la +libtest_ffi_la_SOURCES = test-ffi-lib.c +libtest_ffi_la_CFLAGS = ${test_cflags} +libtest_ffi_la_LDFLAGS = -module -no-undefined -rpath `pwd` # so libtool will really build an .so +libtest_ffi_la_LIBADD = $(LIBGUILE_LDADD) +check_SCRIPTS += test-ffi +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} +test_list_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-list +TESTS += test-list + +# test-unwind +test_unwind_SOURCES = test-unwind.c +test_unwind_CFLAGS = ${test_cflags} +test_unwind_LDADD = $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la +check_PROGRAMS += test-unwind +TESTS += test-unwind + +# test-conversion +test_conversion_SOURCES = test-conversion.c +test_conversion_CFLAGS = ${test_cflags} +test_conversion_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-conversion +TESTS += test-conversion + +# test-loose-ends +test_loose_ends_SOURCES = test-loose-ends.c +test_loose_ends_CFLAGS = ${test_cflags} +test_loose_ends_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-loose-ends +TESTS += test-loose-ends + +# test-fast-slot-ref +check_SCRIPTS += test-fast-slot-ref +TESTS += test-fast-slot-ref + +# test-mb-regexp +check_SCRIPTS += test-mb-regexp +TESTS += test-mb-regexp + +# test-use-srfi +check_SCRIPTS += test-use-srfi +TESTS += test-use-srfi + +# test-scm-c-read +test_scm_c_read_SOURCES = test-scm-c-read.c +test_scm_c_read_CFLAGS = ${test_cflags} +test_scm_c_read_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-c-read +TESTS += test-scm-c-read + +# test-scm-take-locale-symbol +test_scm_take_locale_symbol_SOURCES = test-scm-take-locale-symbol.c +test_scm_take_locale_symbol_CFLAGS = ${test_cflags} +test_scm_take_locale_symbol_LDADD = \ + $(LIBGUILE_LDADD) $(top_builddir)/lib/libgnu.la +check_PROGRAMS += test-scm-take-locale-symbol +TESTS += test-scm-take-locale-symbol + +# test-scm-take-u8vector +test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c +test_scm_take_u8vector_CFLAGS = ${test_cflags} +test_scm_take_u8vector_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-take-u8vector +TESTS += test-scm-take-u8vector + +# test-scm-take-u8vector +test_scm_to_latin1_string_SOURCES = test-scm-to-latin1-string.c +test_scm_to_latin1_string_CFLAGS = ${test_cflags} +test_scm_to_latin1_string_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-to-latin1-string +TESTS += test-scm-to-latin1-string + +# test-scm-values +test_scm_values_SOURCES = test-scm-values.c +test_scm_values_CFLAGS = ${test_cflags} +test_scm_values_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-values +TESTS += test-scm-values + +# test-scm-c-bind-keyword-arguments +test_scm_c_bind_keyword_arguments_SOURCES = test-scm-c-bind-keyword-arguments.c +test_scm_c_bind_keyword_arguments_CFLAGS = ${test_cflags} +test_scm_c_bind_keyword_arguments_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-c-bind-keyword-arguments +TESTS += test-scm-c-bind-keyword-arguments + +# test-srfi-4 +test_srfi_4_SOURCES = test-srfi-4.c +test_srfi_4_CFLAGS = ${test_cflags} +test_srfi_4_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-srfi-4 +TESTS += test-srfi-4 + +if HAVE_SHARED_LIBRARIES + +# test-extensions +noinst_LTLIBRARIES += libtest-extensions.la +libtest_extensions_la_SOURCES = test-extensions-lib.c +libtest_extensions_la_CFLAGS = ${test_cflags} +libtest_extensions_la_LDFLAGS = -module -no-undefined -rpath `pwd` # so libtool will really build an .so +libtest_extensions_la_LIBADD = $(LIBGUILE_LDADD) +check_SCRIPTS += test-extensions +TESTS += test-extensions + +endif HAVE_SHARED_LIBRARIES + +if BUILD_PTHREAD_SUPPORT + +# test-with-guile-module +test_with_guile_module_CFLAGS = ${test_cflags} +test_with_guile_module_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-with-guile-module +TESTS += test-with-guile-module + +test_scm_with_guile_CFLAGS = ${test_cflags} +test_scm_with_guile_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-with-guile +TESTS += test-scm-with-guile + +test_scm_spawn_thread_CFLAGS = ${test_cflags} +test_scm_spawn_thread_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-scm-spawn-thread +TESTS += test-scm-spawn-thread + +test_pthread_create_CFLAGS = ${test_cflags} +test_pthread_create_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-pthread-create +TESTS += test-pthread-create + +test_pthread_create_secondary_CFLAGS = ${test_cflags} $(BDW_GC_CFLAGS) +test_pthread_create_secondary_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-pthread-create-secondary +TESTS += test-pthread-create-secondary + +else + +EXTRA_DIST += test-with-guile-module.c test-scm-with-guile.c + +endif + +test_smob_mark_SOURCES = test-smob-mark.c +test_smob_mark_CFLAGS = ${test_cflags} +test_smob_mark_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-smob-mark +TESTS += test-smob-mark + +test_smob_mark_race_SOURCES = test-smob-mark-race.c +test_smob_mark_race_CFLAGS = ${test_cflags} +test_smob_mark_race_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-smob-mark-race +TESTS += test-smob-mark-race + +check_SCRIPTS += test-stack-overflow +TESTS += test-stack-overflow + +check_SCRIPTS += test-out-of-memory +TESTS += test-out-of-memory + +EXTRA_DIST += ${check_SCRIPTS} diff --git a/test-suite/standalone/README b/test-suite/standalone/README new file mode 100644 index 000000000..164c6ab46 --- /dev/null +++ b/test-suite/standalone/README @@ -0,0 +1,29 @@ +-*-text-*- + +These tests use the standard automake TESTS mechanism. Tests should +be listed in TESTS in Makefile.am, and should exit with 0 on success, +non-zero on failure, and 77 if the result should be ignored. See the +automake info pages for more information. + +If you want to use a scheme script, prefix it as follows: + + #!/bin/sh + exec guile -s "$0" "$@" + !# + +Makefile.am will arrange for all tests (scripts or executables) to be +run under uninstalled-env so that the PATH, LD_LIBRARY_PATH, and +GUILE_LOAD_PATH will be augmented appropriately. + +The Makefile.am has an example of creating a shared library to be used +from a test scheme script as well. + +You can also create standalone executables that include your own code, +are linked against libguile, and that run a given test script (or +scripts). One way to do this is to create the binary, make sure it +calls scm_shell (argc, argv) as its final action, and put this bit at +the top of your test script: + + #!./my-test-binary -s + !# + diff --git a/test-suite/standalone/test-asmobs b/test-suite/standalone/test-asmobs new file mode 100755 index 000000000..9689ab9c6 --- /dev/null +++ b/test-suite/standalone/test-asmobs @@ -0,0 +1,118 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +(load-extension (string-append (getenv "builddir") "/libtest-asmobs") + "libtest_asmobs_init") + +(define (test x v) + (if v + (if (not (equal? (eval x (current-module)) v)) + (error "Wrong return value" x)) + (catch #t + (lambda () + (begin (eval x (current-module)) + (throw 'should-be-error))) + (lambda (key . args) + (if (eq? key 'should-be-error) + (error "Should be error" x)))))) + +(define asmob000 (make-asmob000)) +(test '(asmob000) '()) +(test '(asmob000 1) #f) +(test '(asmob000 1 2) #f) +(test '(asmob000 1 2 3) #f) + +(define asmob100 (make-asmob100)) +(test '(asmob100) #f) +(test '(asmob100 1) '(1)) +(test '(asmob100 1 2) #f) +(test '(asmob100 1 2 3) #f) + +(define asmob010 (make-asmob010)) +(test '(asmob010) '(#f)) +(test '(asmob010 1) '(1)) +(test '(asmob010 1 2) #f) +(test '(asmob010 1 2 3) #f) + +(define asmob001 (make-asmob001)) +(test '(asmob001) '(())) +(test '(asmob001 1) '((1))) +(test '(asmob001 1 2) '((1 2))) +(test '(asmob001 1 2 3) '((1 2 3))) + +(define asmob200 (make-asmob200)) +(test '(asmob200) #f) +(test '(asmob200 1) #f) +(test '(asmob200 1 2) '(1 2)) +(test '(asmob200 1 2 3) #f) + +(define asmob110 (make-asmob110)) +(test '(asmob110) #f) +(test '(asmob110 1) '(1 #f)) +(test '(asmob110 1 2) '(1 2)) +(test '(asmob110 1 2 3) #f) + +(define asmob020 (make-asmob020)) +(test '(asmob020) '(#f #f)) +(test '(asmob020 1) '(1 #f)) +(test '(asmob020 1 2) '(1 2)) +(test '(asmob020 1 2 3) #f) + +(define asmob101 (make-asmob101)) +(test '(asmob101) #f) +(test '(asmob101 1) '(1 ())) +(test '(asmob101 1 2) '(1 (2))) +(test '(asmob101 1 2 3) '(1 (2 3))) + +(define asmob011 (make-asmob011)) +(test '(asmob011) '(#f ())) +(test '(asmob011 1) '(1 ())) +(test '(asmob011 1 2) '(1 (2))) +(test '(asmob011 1 2 3) '(1 (2 3))) + +(define asmob300 (make-asmob300)) +(test '(asmob300) #f) +(test '(asmob300 1) #f) +(test '(asmob300 1 2) #f) +(test '(asmob300 1 2 3) '(1 2 3)) + +(define asmob210 (make-asmob210)) +(test '(asmob210) #f) +(test '(asmob210 1) #f) +(test '(asmob210 1 2) '(1 2 #f)) +(test '(asmob210 1 2 3) '(1 2 3)) + +(define asmob120 (make-asmob120)) +(test '(asmob120) #f) +(test '(asmob120 1) '(1 #f #f)) +(test '(asmob120 1 2) '(1 2 #f)) +(test '(asmob120 1 2 3) '(1 2 3)) + +(define asmob030 (make-asmob030)) +(test '(asmob030) '(#f #f #f)) +(test '(asmob030 1) '(1 #f #f)) +(test '(asmob030 1 2) '(1 2 #f)) +(test '(asmob030 1 2 3) '(1 2 3)) + +(define asmob201 (make-asmob201)) +(test '(asmob201) #f) +(test '(asmob201 1) #f) +(test '(asmob201 1 2) '(1 2 ())) +(test '(asmob201 1 2 3) '(1 2 (3))) + +(define asmob021 (make-asmob021)) +(test '(asmob021) '(#f #f ())) +(test '(asmob021 1) '(1 #f ())) +(test '(asmob021 1 2) '(1 2 ())) +(test '(asmob021 1 2 3) '(1 2 (3))) + +(define asmob111 (make-asmob111)) +(test '(asmob111) #f) +(test '(asmob111 1) '(1 #f ())) +(test '(asmob111 1 2) '(1 2 ())) +(test '(asmob111 1 2 3) '(1 2 (3))) + +;; Local Variables: +;; mode: scheme +;; End:
\ No newline at end of file diff --git a/test-suite/standalone/test-asmobs-lib.c b/test-suite/standalone/test-asmobs-lib.c new file mode 100644 index 000000000..965843fa4 --- /dev/null +++ b/test-suite/standalone/test-asmobs-lib.c @@ -0,0 +1,210 @@ +/* Copyright 1999-2001,2003,2006,2008,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +long asmob000; +long asmob100; +long asmob010; +long asmob001; +long asmob200; +long asmob110; +long asmob020; +long asmob101; +long asmob011; +long asmob300; +long asmob210; +long asmob120; +long asmob030; +long asmob201; +long asmob021; +long asmob111; + +/* since we don't have SCM_DEFINE_STATIC or similar */ +SCM scm_make_asmob000 (void); +SCM scm_make_asmob001 (void); +SCM scm_make_asmob010 (void); +SCM scm_make_asmob011 (void); +SCM scm_make_asmob100 (void); +SCM scm_make_asmob101 (void); +SCM scm_make_asmob110 (void); +SCM scm_make_asmob111 (void); +SCM scm_make_asmob120 (void); +SCM scm_make_asmob020 (void); +SCM scm_make_asmob021 (void); +SCM scm_make_asmob200 (void); +SCM scm_make_asmob201 (void); +SCM scm_make_asmob210 (void); +SCM scm_make_asmob030 (void); +SCM scm_make_asmob300 (void); + + +SCM_DEFINE (scm_make_asmob000, "make-asmob000", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob000, 0); +} + +SCM_DEFINE (scm_make_asmob100, "make-asmob100", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob100, 0); +} + +SCM_DEFINE (scm_make_asmob010, "make-asmob010", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob010, 0); +} + +SCM_DEFINE (scm_make_asmob001, "make-asmob001", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob001, 0); +} + +SCM_DEFINE (scm_make_asmob200, "make-asmob200", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob200, 0); +} + +SCM_DEFINE (scm_make_asmob110, "make-asmob110", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob110, 0); +} + +SCM_DEFINE (scm_make_asmob020, "make-asmob020", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob020, 0); +} + +SCM_DEFINE (scm_make_asmob101, "make-asmob101", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob101, 0); +} + +SCM_DEFINE (scm_make_asmob011, "make-asmob011", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob011, 0); +} + +SCM_DEFINE (scm_make_asmob300, "make-asmob300", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob300, 0); +} + +SCM_DEFINE (scm_make_asmob210, "make-asmob210", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob210, 0); +} + +SCM_DEFINE (scm_make_asmob120, "make-asmob120", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob120, 0); +} + +SCM_DEFINE (scm_make_asmob030, "make-asmob030", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob030, 0); +} + +SCM_DEFINE (scm_make_asmob201, "make-asmob201", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob201, 0); +} + +SCM_DEFINE (scm_make_asmob021, "make-asmob021", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob021, 0); +} + +SCM_DEFINE (scm_make_asmob111, "make-asmob111", 0, 0, 0, (), "") +{ + SCM_RETURN_NEWSMOB (asmob111, 0); +} + +static SCM +apply0 (SCM smob) +{ + return SCM_EOL; +} + +static SCM +apply1 (SCM smob, SCM a1) +{ + if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F; + return scm_list_1 (a1); +} + +static SCM +apply2 (SCM smob, SCM a1, SCM a2) +{ + if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F; + if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F; + return scm_list_2 (a1, a2); +} + +static SCM +apply3 (SCM smob, SCM a1, SCM a2, SCM rest) +{ + if (SCM_UNBNDP (a1)) a1 = SCM_BOOL_F; + if (SCM_UNBNDP (a2)) a2 = SCM_BOOL_F; + if (SCM_UNBNDP (rest)) rest = SCM_BOOL_F; + return scm_list_3 (a1, a2, rest); +} + +void libtest_asmobs_init (void); + +void +libtest_asmobs_init () +{ + asmob000 = scm_make_smob_type ("asmob000", 0); + scm_set_smob_apply (asmob000, apply0, 0, 0, 0); + asmob100 = scm_make_smob_type ("asmob100", 0); + scm_set_smob_apply (asmob100, apply1, 1, 0, 0); + asmob010 = scm_make_smob_type ("asmob010", 0); + scm_set_smob_apply (asmob010, apply1, 0, 1, 0); + asmob001 = scm_make_smob_type ("asmob001", 0); + scm_set_smob_apply (asmob001, apply1, 0, 0, 1); + asmob200 = scm_make_smob_type ("asmob200", 0); + scm_set_smob_apply (asmob200, apply2, 2, 0, 0); + asmob110 = scm_make_smob_type ("asmob110", 0); + scm_set_smob_apply (asmob110, apply2, 1, 1, 0); + asmob020 = scm_make_smob_type ("asmob020", 0); + scm_set_smob_apply (asmob020, apply2, 0, 2, 0); + asmob101 = scm_make_smob_type ("asmob101", 0); + scm_set_smob_apply (asmob101, apply2, 1, 0, 1); + asmob011 = scm_make_smob_type ("asmob011", 0); + scm_set_smob_apply (asmob011, apply2, 0, 1, 1); + asmob300 = scm_make_smob_type ("asmob300", 0); + scm_set_smob_apply (asmob300, apply3, 3, 0, 0); + asmob210 = scm_make_smob_type ("asmob210", 0); + scm_set_smob_apply (asmob210, apply3, 2, 1, 0); + asmob120 = scm_make_smob_type ("asmob120", 0); + scm_set_smob_apply (asmob120, apply3, 1, 2, 0); + asmob030 = scm_make_smob_type ("asmob030", 0); + scm_set_smob_apply (asmob030, apply3, 0, 3, 0); + asmob201 = scm_make_smob_type ("asmob201", 0); + scm_set_smob_apply (asmob201, apply3, 2, 0, 1); + asmob021 = scm_make_smob_type ("asmob021", 0); + scm_set_smob_apply (asmob021, apply3, 0, 2, 1); + asmob111 = scm_make_smob_type ("asmob111", 0); + scm_set_smob_apply (asmob111, apply3, 1, 1, 1); +# include "test-asmobs-lib.x" +} diff --git a/test-suite/standalone/test-bad-identifiers b/test-suite/standalone/test-bad-identifiers new file mode 100755 index 000000000..e7af5a1d1 --- /dev/null +++ b/test-suite/standalone/test-bad-identifiers @@ -0,0 +1,77 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +;; The use of certain identifiers as variable or parameter names has +;; been found to cause build problems on particular platforms. The +;; aim of this test is to cause "make check" to fail (on GNU/Linux, +;; which most Guile developers use) if we accidentally add new code +;; that uses those identifiers. + +(define bad-identifiers + '( + ;; On AIX 5.2 and 5.3, /usr/include/sys/timer.h includes: + ;; #ifndef _LINUX_SOURCE_COMPAT + ;; #define func_data t_union.data + ;; #endif + ;; So we want to avoid using func_data in Guile source code. + "func_data" + + ;; More troublesome identifiers can be added into the list here. + )) + +(use-modules (ice-9 regex) (ice-9 rdelim)) + +(define bad-id-regexp + (make-regexp (string-append "\\<(" + (string-join (map regexp-quote bad-identifiers) "|") + ")\\>"))) + +(define exit-status 0) + +;; Non-exported code from (ice-9 ftw). +(define (directory-files dir) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + (begin + (closedir dir-stream) + acc) + (loop (readdir dir-stream) + (if (or (string=? "." new) ;;; ignore + (string=? ".." new)) ;;; ignore + acc + (cons (in-vicinity dir new) acc))))))) + +(define (directory-files-matching dir pattern) + (let ((file-name-regexp (make-regexp pattern))) + (filter (lambda (fn) + (regexp-exec file-name-regexp fn)) + (directory-files dir)))) + +(let loop ((file-names (directory-files-matching "../../libguile" + "\\.[ch]$"))) + (or (null? file-names) + (begin + (with-input-from-file (car file-names) + (lambda () + (let loop ((linenum 1) (line (read-line))) + (or (eof-object? line) + (begin + (if (regexp-exec bad-id-regexp line) + (begin + (set! exit-status 1) + (format (current-error-port) + "~a:~a: ~a\n" + (car file-names) + linenum + line))) + (loop (+ linenum 1) (read-line))))))) + (loop (cdr file-names))))) + +(exit exit-status) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-command-line-encoding b/test-suite/standalone/test-command-line-encoding new file mode 100755 index 000000000..525c0aeed --- /dev/null +++ b/test-suite/standalone/test-command-line-encoding @@ -0,0 +1,24 @@ +#!/bin/sh + +# Choose a UTF-8 locale. The locale doesn't have to be available on the +# system since `environ_locale_charset' does not actually try to set it. +LC_ALL="en_US.UTF-8" +export LC_ALL +unset LANG +unset LC_CTYPE + +exec guile -q -s "$0" "λ" +!# + +;; Make sure our first argument is a lower-case lambda. +;; +;; Up to Guile 2.0.3 included, command-line arguments would not be converted +;; according to the locale settings; see +;; <http://lists.gnu.org/archive/html/guile-devel/2011-11/msg00026.html> for +;; details. +(exit (string=? (cadr (program-arguments)) "λ")) + +;; Local Variables: +;; mode: scheme +;; coding: utf-8 +;; End: diff --git a/test-suite/standalone/test-command-line-encoding2 b/test-suite/standalone/test-command-line-encoding2 new file mode 100755 index 000000000..536945bc2 --- /dev/null +++ b/test-suite/standalone/test-command-line-encoding2 @@ -0,0 +1,20 @@ +#!/bin/sh + +# Choose a locale name that lacks a dot followed by the encoding name. +# This should not confuse `environ_locale_charset'. +# See <http://bugs.gnu.org/10742> for the original bug report. +LC_ALL="en_US" +export LC_ALL +unset LANG +unset LC_CTYPE + +exec guile -q -s "$0" "hello" +!# + +;; Make sure our argument was suitable decoded. +(exit (string=? (cadr (program-arguments)) "hello")) + +;; Local Variables: +;; mode: scheme +;; coding: iso-8859-1 +;; End: diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c new file mode 100644 index 000000000..6e3ec6cdd --- /dev/null +++ b/test-suite/standalone/test-conversion.c @@ -0,0 +1,1205 @@ +/* Copyright 1999-2001,2003-2004,2006-2010,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +#ifdef HAVE_INTTYPES_H +# include <inttypes.h> +#endif + +#ifndef PRIiMAX +# if (defined SIZEOF_LONG_LONG) && (SIZEOF_LONG_LONG >= 8) +# define PRIiMAX "lli" +# define PRIuMAX "llu" +# else +# define PRIiMAX "li" +# define PRIuMAX "lu" +# endif +#endif + + +static void +test_1 (const char *str, intmax_t min, intmax_t max, + int result) +{ + int r = scm_is_signed_integer (scm_c_eval_string (str), min, max); + if (r != result) + { + fprintf (stderr, "fail: scm_is_signed_integer (%s, " + "%" PRIiMAX ", %" PRIiMAX ") == %d\n", + str, min, max, result); + exit (EXIT_FAILURE); + } +} + +static void +test_is_signed_integer () +{ + test_1 ("'foo", + INTMAX_MIN, INTMAX_MAX, + 0); + test_1 ("3.0", + INTMAX_MIN, INTMAX_MAX, + 0); + test_1 ("(inexact->exact 3.0)", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("3.5", + INTMAX_MIN, INTMAX_MAX, + 0); + test_1 ("most-positive-fixnum", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(+ most-positive-fixnum 1)", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("most-negative-fixnum", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(- most-negative-fixnum 1)", + INTMAX_MIN, INTMAX_MAX, + 1); + if (sizeof (intmax_t) == 8) + { + test_1 ("(- (expt 2 63) 1)", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(expt 2 63)", + INTMAX_MIN, INTMAX_MAX, + 0); + test_1 ("(- (expt 2 63))", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(- (- (expt 2 63)) 1)", + INTMAX_MIN, INTMAX_MAX, + 0); + } + else if (sizeof (intmax_t) == 4) + { + test_1 ("(- (expt 2 31) 1)", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(expt 2 31)", + INTMAX_MIN, INTMAX_MAX, + 0); + test_1 ("(- (expt 2 31))", + INTMAX_MIN, INTMAX_MAX, + 1); + test_1 ("(- (- (expt 2 31)) 1)", + INTMAX_MIN, INTMAX_MAX, + 0); + } + else + fprintf (stderr, "NOTE: skipped some tests.\n"); + + /* bignum with range that fits into fixnum. */ + test_1 ("(+ most-positive-fixnum 1)", + -32768, 32767, + 0); + + /* bignum with range that doesn't fit into fixnum, but probably + fits into long. */ + test_1 ("(+ most-positive-fixnum 1)", + SCM_MOST_NEGATIVE_FIXNUM-1, SCM_MOST_POSITIVE_FIXNUM+1, + 1); +} + +static void +test_2 (const char *str, uintmax_t min, uintmax_t max, + int result) +{ + int r = scm_is_unsigned_integer (scm_c_eval_string (str), min, max); + if (r != result) + { + fprintf (stderr, "fail: scm_is_unsigned_integer (%s, " + "%" PRIuMAX ", %" PRIuMAX ") == %d\n", + str, min, max, result); + exit (EXIT_FAILURE); + } +} + +static void +test_is_unsigned_integer () +{ + test_2 ("'foo", + 0, UINTMAX_MAX, + 0); + test_2 ("3.0", + 0, UINTMAX_MAX, + 0); + test_2 ("(inexact->exact 3.0)", + 0, UINTMAX_MAX, + 1); + test_2 ("3.5", + 0, UINTMAX_MAX, + 0); + test_2 ("most-positive-fixnum", + 0, UINTMAX_MAX, + 1); + test_2 ("(+ most-positive-fixnum 1)", + 0, UINTMAX_MAX, + 1); + test_2 ("most-negative-fixnum", + 0, UINTMAX_MAX, + 0); + test_2 ("(- most-negative-fixnum 1)", + 0, UINTMAX_MAX, + 0); + if (sizeof (intmax_t) == 8) + { + test_2 ("(- (expt 2 64) 1)", + 0, UINTMAX_MAX, + 1); + test_2 ("(expt 2 64)", + 0, UINTMAX_MAX, + 0); + } + else if (sizeof (intmax_t) == 4) + { + test_2 ("(- (expt 2 32) 1)", + 0, UINTMAX_MAX, + 1); + test_2 ("(expt 2 32)", + 0, UINTMAX_MAX, + 0); + } + else + fprintf (stderr, "NOTE: skipped some tests.\n"); + + /* bignum with range that fits into fixnum. */ + test_2 ("(+ most-positive-fixnum 1)", + 0, 32767, + 0); + + /* bignum with range that doesn't fit into fixnum, but probably + fits into long. */ + test_2 ("(+ most-positive-fixnum 1)", + 0, SCM_MOST_POSITIVE_FIXNUM+1, + 1); +} + +typedef struct { + SCM val; + intmax_t min, max; + intmax_t result; +} to_signed_data; + +static SCM +out_of_range_handler (void *data, SCM key, SCM args) +{ + return scm_equal_p (key, scm_from_locale_symbol ("out-of-range")); +} + +static SCM +wrong_type_handler (void *data, SCM key, SCM args) +{ + return scm_equal_p (key, scm_from_locale_symbol ("wrong-type-arg")); +} + +static SCM +misc_error_handler (void *data, SCM key, SCM args) +{ + return scm_equal_p (key, scm_from_locale_symbol ("misc-error")); +} + +static SCM +any_handler (void *data, SCM key, SCM args) +{ + return SCM_BOOL_T; +} + +static SCM +to_signed_integer_body (void *data) +{ + to_signed_data *d = (to_signed_data *)data; + d->result = scm_to_signed_integer (d->val, d->min, d->max); + return SCM_BOOL_F; +} + +static void +test_3 (const char *str, intmax_t min, intmax_t max, + intmax_t result, int range_error, int type_error) +{ + to_signed_data data; + data.val = scm_c_eval_string (str); + data.min = min; + data.max = max; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_integer_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_signed_int (%s, " + "%" PRIiMAX ", %" PRIiMAX ") -> out of range\n", + str, min, max); + exit (EXIT_FAILURE); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_integer_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_signed_int (%s, " + "%" PRIiMAX", %" PRIiMAX ") -> wrong type\n", + str, min, max); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_signed_integer_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: scm_to_signed_int (%s, " + "%" PRIiMAX ", %" PRIiMAX ") = %" PRIiMAX "\n", + str, min, max, result); + exit (EXIT_FAILURE); + } + } +} + +static void +test_to_signed_integer () +{ + test_3 ("'foo", + INTMAX_MIN, INTMAX_MAX, + 0, 0, 1); + test_3 ("3.5", + INTMAX_MIN, INTMAX_MAX, + 0, 0, 1); + test_3 ("12", + INTMAX_MIN, INTMAX_MAX, + 12, 0, 0); + test_3 ("1000", + -999, 999, + 0, 1, 0); + test_3 ("-1000", + -999, 999, + 0, 1, 0); + test_3 ("most-positive-fixnum", + INTMAX_MIN, INTMAX_MAX, + SCM_MOST_POSITIVE_FIXNUM, 0, 0); + test_3 ("most-negative-fixnum", + INTMAX_MIN, INTMAX_MAX, + SCM_MOST_NEGATIVE_FIXNUM, 0, 0); + test_3 ("(+ most-positive-fixnum 1)", + INTMAX_MIN, INTMAX_MAX, + SCM_MOST_POSITIVE_FIXNUM+1, 0, 0); + test_3 ("(- most-negative-fixnum 1)", + INTMAX_MIN, INTMAX_MAX, + SCM_MOST_NEGATIVE_FIXNUM-1, 0, 0); + if (sizeof (intmax_t) == 8) + { + test_3 ("(- (expt 2 63) 1)", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MAX, 0, 0); + test_3 ("(+ (- (expt 2 63)) 1)", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MIN+1, 0, 0); + test_3 ("(- (expt 2 63))", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MIN, 0, 0); + test_3 ("(expt 2 63)", + INTMAX_MIN, INTMAX_MAX, + 0, 1, 0); + test_3 ("(- (- (expt 2 63)) 1)", + INTMAX_MIN, INTMAX_MAX, + 0, 1, 0); + } + else if (sizeof (intmax_t) == 4) + { + test_3 ("(- (expt 2 31) 1)", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MAX, 0, 0); + test_3 ("(+ (- (expt 2 31)) 1)", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MIN+1, 0, 0); + test_3 ("(- (expt 2 31))", + INTMAX_MIN, INTMAX_MAX, + INTMAX_MIN, 0, 0); + test_3 ("(expt 2 31)", + INTMAX_MIN, INTMAX_MAX, + 0, 1, 0); + test_3 ("(- (- (expt 2 31)) 1)", + INTMAX_MIN, INTMAX_MAX, + 0, 1, 0); + } + else + fprintf (stderr, "NOTE: skipped some tests.\n"); +} + +typedef struct { + SCM val; + uintmax_t min, max; + uintmax_t result; +} to_unsigned_data; + +static SCM +to_unsigned_integer_body (void *data) +{ + to_unsigned_data *d = (to_unsigned_data *)data; + d->result = scm_to_unsigned_integer (d->val, d->min, d->max); + return SCM_BOOL_F; +} + +static void +test_4 (const char *str, uintmax_t min, uintmax_t max, + uintmax_t result, int range_error, int type_error) +{ + to_unsigned_data data; + data.val = scm_c_eval_string (str); + data.min = min; + data.max = max; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_integer_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_unsigned_int (%s, " + "%" PRIuMAX ", %" PRIuMAX ") -> out of range\n", + str, min, max); + exit (EXIT_FAILURE); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_integer_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_unsigned_int (%s, " + "%" PRIuMAX ", %" PRIuMAX ") -> wrong type\n", + str, min, max); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_unsigned_integer_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: scm_to_unsigned_int (%s, " + "%" PRIuMAX ", %" PRIuMAX ") == %" PRIuMAX "\n", + str, min, max, result); + exit (EXIT_FAILURE); + } + } +} + +static void +test_to_unsigned_integer () +{ + test_4 ("'foo", + 0, UINTMAX_MAX, + 0, 0, 1); + test_4 ("3.5", + 0, UINTMAX_MAX, + 0, 0, 1); + test_4 ("12", + 0, UINTMAX_MAX, + 12, 0, 0); + test_4 ("1000", + 0, 999, + 0, 1, 0); + test_4 ("most-positive-fixnum", + 0, UINTMAX_MAX, + SCM_MOST_POSITIVE_FIXNUM, 0, 0); + test_4 ("(+ most-positive-fixnum 1)", + 0, UINTMAX_MAX, + SCM_MOST_POSITIVE_FIXNUM+1, 0, 0); + if (sizeof (intmax_t) == 8) + { + test_4 ("(- (expt 2 64) 1)", + 0, UINTMAX_MAX, + UINTMAX_MAX, 0, 0); + test_4 ("(expt 2 64)", + 0, UINTMAX_MAX, + 0, 1, 0); + } + else if (sizeof (intmax_t) == 4) + { + test_4 ("(- (expt 2 32) 1)", + 0, UINTMAX_MAX, + UINTMAX_MAX, 0, 0); + test_4 ("(expt 2 32)", + 0, UINTMAX_MAX, + 0, 1, 0); + } + else + fprintf (stderr, "NOTE: skipped some tests.\n"); +} + +static void +test_5 (intmax_t val, const char *result) +{ + SCM res = scm_c_eval_string (result); + if (scm_is_false (scm_equal_p (scm_from_signed_integer (val), res))) + { + fprintf (stderr, "fail: scm_from_signed_integer (%" PRIiMAX ") == %s\n", + val, result); + exit (EXIT_FAILURE); + } +} + +static void +test_from_signed_integer () +{ + test_5 (12, "12"); + if (sizeof (intmax_t) == 8) + { + test_5 (INTMAX_MAX, "(- (expt 2 63) 1)"); + test_5 (INTMAX_MIN, "(- (expt 2 63))"); + } + else if (sizeof (intmax_t) == 4) + { + test_5 (INTMAX_MAX, "(- (expt 2 31) 1)"); + test_5 (INTMAX_MIN, "(- (expt 2 31))"); + } + test_5 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum"); + test_5 (SCM_MOST_NEGATIVE_FIXNUM, "most-negative-fixnum"); + test_5 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)"); + test_5 (SCM_MOST_NEGATIVE_FIXNUM-1, "(- most-negative-fixnum 1)"); +} + +static void +test_6 (uintmax_t val, const char *result) +{ + SCM res = scm_c_eval_string (result); + if (scm_is_false (scm_equal_p (scm_from_unsigned_integer (val), res))) + { + fprintf (stderr, "fail: scm_from_unsigned_integer (%" + PRIuMAX ") == %s\n", + val, result); + exit (EXIT_FAILURE); + } +} + +static void +test_from_unsigned_integer () +{ + test_6 (12, "12"); + if (sizeof (intmax_t) == 8) + { + test_6 (UINTMAX_MAX, "(- (expt 2 64) 1)"); + } + else if (sizeof (intmax_t) == 4) + { + test_6 (UINTMAX_MAX, "(- (expt 2 32) 1)"); + } + test_6 (SCM_MOST_POSITIVE_FIXNUM, "most-positive-fixnum"); + test_6 (SCM_MOST_POSITIVE_FIXNUM+1, "(+ most-positive-fixnum 1)"); +} + +static void +test_7s (SCM n, intmax_t c_n, const char *result, const char *func) +{ + SCM r = scm_c_eval_string (result); + + if (scm_is_false (scm_equal_p (n, r))) + { + fprintf (stderr, "fail: %s (%" PRIiMAX ") == %s\n", func, c_n, result); + exit (EXIT_FAILURE); + } +} + +#define TEST_7S(func,arg,res) test_7s (func(arg), arg, res, #func) + +static void +test_7u (SCM n, uintmax_t c_n, const char *result, const char *func) +{ + SCM r = scm_c_eval_string (result); + + if (scm_is_false (scm_equal_p (n, r))) + { + fprintf (stderr, "fail: %s (%" PRIuMAX ") == %s\n", func, c_n, result); + exit (EXIT_FAILURE); + } +} + +#define TEST_7U(func,arg,res) test_7u (func(arg), arg, res, #func) + +typedef struct { + SCM val; + intmax_t (*func) (SCM); + intmax_t result; +} to_signed_func_data; + +static SCM +to_signed_func_body (void *data) +{ + to_signed_func_data *d = (to_signed_func_data *)data; + d->result = d->func (d->val); + return SCM_BOOL_F; +} + +static void +test_8s (const char *str, intmax_t (*func) (SCM), const char *func_name, + intmax_t result, int range_error, int type_error) +{ + to_signed_func_data data; + data.val = scm_c_eval_string (str); + data.func = func; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> out of range\n", func_name, str); + exit (EXIT_FAILURE); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> wrong type\n", func_name, str); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_signed_func_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result); + exit (EXIT_FAILURE); + } + } +} + +typedef struct { + SCM val; + uintmax_t (*func) (SCM); + uintmax_t result; +} to_unsigned_func_data; + +static SCM +to_unsigned_func_body (void *data) +{ + to_unsigned_func_data *d = (to_unsigned_func_data *)data; + d->result = d->func (d->val); + return SCM_BOOL_F; +} + +static void +test_8u (const char *str, uintmax_t (*func) (SCM), const char *func_name, + uintmax_t result, int range_error, int type_error) +{ + to_unsigned_func_data data; + data.val = scm_c_eval_string (str); + data.func = func; + + if (range_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + out_of_range_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> out of range\n", func_name, str); + exit (EXIT_FAILURE); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: %s (%s) -> wrong type\n", func_name, str); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_unsigned_func_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: %s (%s) = %" PRIiMAX "\n", func_name, str, result); + exit (EXIT_FAILURE); + } + } +} + +/* We can't rely on the scm_to functions being proper functions but we + want to pass them to test_8s and test_8u, so we wrap'em. Also, we + need to give them a common return type. +*/ + +#define DEFSTST(f) static intmax_t tst_##f (SCM x) { return f(x); } +#define DEFUTST(f) static uintmax_t tst_##f (SCM x) { return f(x); } + +DEFSTST (scm_to_schar) +DEFUTST (scm_to_uchar) +DEFSTST (scm_to_char) +DEFSTST (scm_to_short) +DEFUTST (scm_to_ushort) +DEFSTST (scm_to_int) +DEFUTST (scm_to_uint) +DEFSTST (scm_to_long) +DEFUTST (scm_to_ulong) +#if SCM_SIZEOF_LONG_LONG != 0 +DEFSTST (scm_to_long_long) +DEFUTST (scm_to_ulong_long) +#endif +DEFSTST (scm_to_ssize_t) +DEFUTST (scm_to_size_t) + +DEFSTST (scm_to_int8) +DEFUTST (scm_to_uint8) +DEFSTST (scm_to_int16) +DEFUTST (scm_to_uint16) +DEFSTST (scm_to_int32) +DEFUTST (scm_to_uint32) +DEFSTST (scm_to_int64) +DEFUTST (scm_to_uint64) + +#define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te) +#define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te) + + +static void +test_int_sizes () +{ + TEST_7U (scm_from_uchar, 91, "91"); + TEST_7S (scm_from_schar, 91, "91"); + TEST_7S (scm_from_char, 91, "91"); + TEST_7S (scm_from_short, -911, "-911"); + TEST_7U (scm_from_ushort, 911, "911"); + TEST_7S (scm_from_int, 911, "911"); + TEST_7U (scm_from_uint, 911, "911"); + TEST_7S (scm_from_long, 911, "911"); + TEST_7U (scm_from_ulong, 911, "911"); +#if SCM_SIZEOF_LONG_LONG != 0 + TEST_7S (scm_from_long_long, 911, "911"); + TEST_7U (scm_from_ulong_long, 911, "911"); +#endif + TEST_7U (scm_from_size_t, 911, "911"); + TEST_7S (scm_from_ssize_t, 911, "911"); + + TEST_7S (scm_from_int8, -128, "-128"); + TEST_7S (scm_from_int8, 127, "127"); + TEST_7S (scm_from_int8, 128, "-128"); + TEST_7U (scm_from_uint8, 255, "255"); + + TEST_7S (scm_from_int16, -32768, "-32768"); + TEST_7S (scm_from_int16, 32767, "32767"); + TEST_7S (scm_from_int16, 32768, "-32768"); + TEST_7U (scm_from_uint16, 65535, "65535"); + + TEST_7S (scm_from_int32, INT32_MIN, "-2147483648"); + TEST_7S (scm_from_int32, INT32_MAX, "2147483647"); + TEST_7S (scm_from_int32, INT32_MAX+1LL, "-2147483648"); + TEST_7U (scm_from_uint32, UINT32_MAX, "4294967295"); + + TEST_7S (scm_from_int64, INT64_MIN, "-9223372036854775808"); + TEST_7S (scm_from_int64, INT64_MAX, "9223372036854775807"); + TEST_7U (scm_from_uint64, UINT64_MAX, "18446744073709551615"); + + TEST_8S ("91", scm_to_schar, 91, 0, 0); + TEST_8U ("91", scm_to_uchar, 91, 0, 0); + TEST_8S ("91", scm_to_char, 91, 0, 0); + TEST_8S ("-911", scm_to_short, -911, 0, 0); + TEST_8U ("911", scm_to_ushort, 911, 0, 0); + TEST_8S ("-911", scm_to_int, -911, 0, 0); + TEST_8U ("911", scm_to_uint, 911, 0, 0); + TEST_8S ("-911", scm_to_long, -911, 0, 0); + TEST_8U ("911", scm_to_ulong, 911, 0, 0); +#if SCM_SIZEOF_LONG_LONG != 0 + TEST_8S ("-911", scm_to_long_long, -911, 0, 0); + TEST_8U ("911", scm_to_ulong_long, 911, 0, 0); +#endif + TEST_8U ("911", scm_to_size_t, 911, 0, 0); + TEST_8S ("911", scm_to_ssize_t, 911, 0, 0); + + TEST_8S ("-128", scm_to_int8, INT8_MIN, 0, 0); + TEST_8S ("127", scm_to_int8, INT8_MAX, 0, 0); + TEST_8S ("128", scm_to_int8, 0, 1, 0); + TEST_8S ("#f", scm_to_int8, 0, 0, 1); + TEST_8U ("255", scm_to_uint8, UINT8_MAX, 0, 0); + TEST_8U ("256", scm_to_uint8, 0, 1, 0); + TEST_8U ("-1", scm_to_uint8, 0, 1, 0); + TEST_8U ("#f", scm_to_uint8, 0, 0, 1); + + TEST_8S ("-32768", scm_to_int16, INT16_MIN, 0, 0); + TEST_8S ("32767", scm_to_int16, INT16_MAX, 0, 0); + TEST_8S ("32768", scm_to_int16, 0, 1, 0); + TEST_8S ("#f", scm_to_int16, 0, 0, 1); + TEST_8U ("65535", scm_to_uint16, UINT16_MAX, 0, 0); + TEST_8U ("65536", scm_to_uint16, 0, 1, 0); + TEST_8U ("-1", scm_to_uint16, 0, 1, 0); + TEST_8U ("#f", scm_to_uint16, 0, 0, 1); + + TEST_8S ("-2147483648", scm_to_int32, INT32_MIN, 0, 0); + TEST_8S ("2147483647", scm_to_int32, INT32_MAX, 0, 0); + TEST_8S ("2147483648", scm_to_int32, 0, 1, 0); + TEST_8S ("#f", scm_to_int32, 0, 0, 1); + TEST_8U ("4294967295", scm_to_uint32, UINT32_MAX, 0, 0); + TEST_8U ("4294967296", scm_to_uint32, 0, 1, 0); + TEST_8U ("-1", scm_to_uint32, 0, 1, 0); + TEST_8U ("#f", scm_to_uint32, 0, 0, 1); + + TEST_8S ("-9223372036854775808", scm_to_int64, INT64_MIN, 0, 0); + TEST_8S ("9223372036854775807", scm_to_int64, INT64_MAX, 0, 0); + TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0); + TEST_8S ("#f", scm_to_int64, 0, 0, 1); + TEST_8U ("18446744073709551615", scm_to_uint64, UINT64_MAX, 0, 0); + TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0); + TEST_8U ("-1", scm_to_uint64, 0, 1, 0); + TEST_8U ("#f", scm_to_uint64, 0, 0, 1); + +} + +static void +test_9 (double val, const char *result) +{ + SCM res = scm_c_eval_string (result); + if (scm_is_false (scm_eqv_p (res, scm_from_double (val)))) + { + fprintf (stderr, "fail: scm_from_double (%g) == %s\n", val, result); + exit (EXIT_FAILURE); + } +} + +/* The `infinity' and `not-a-number' values. */ +static double guile_Inf, guile_NaN; + +/* Initialize GUILE_INF and GUILE_NAN. Taken from `guile_ieee_init ()' in + `libguile/numbers.c'. */ +static void +ieee_init (void) +{ +#ifdef INFINITY + /* C99 INFINITY, when available. + FIXME: The standard allows for INFINITY to be something that overflows + at compile time. We ought to have a configure test to check for that + before trying to use it. (But in practice we believe this is not a + problem on any system guile is likely to target.) */ + guile_Inf = INFINITY; +#elif defined HAVE_DINFINITY + /* OSF */ + extern unsigned int DINFINITY[2]; + guile_Inf = (*((double *) (DINFINITY))); +#else + double tmp = 1e+10; + guile_Inf = tmp; + for (;;) + { + guile_Inf *= 1e+10; + if (guile_Inf == tmp) + break; + tmp = guile_Inf; + } +#endif + +#ifdef NAN + /* C99 NAN, when available */ + guile_NaN = NAN; +#elif defined HAVE_DQNAN + { + /* OSF */ + extern unsigned int DQNAN[2]; + guile_NaN = (*((double *)(DQNAN))); + } +#else + guile_NaN = guile_Inf / guile_Inf; +#endif +} + +static void +test_from_double () +{ + test_9 (12, "12.0"); + test_9 (0.25, "0.25"); + test_9 (0.1, "0.1"); + test_9 (guile_Inf, "+inf.0"); + test_9 (-guile_Inf, "-inf.0"); + test_9 (guile_NaN, "+nan.0"); +} + +typedef struct { + SCM val; + double result; +} to_double_data; + +static SCM +to_double_body (void *data) +{ + to_double_data *d = (to_double_data *)data; + d->result = scm_to_double (d->val); + return SCM_BOOL_F; +} + +static void +test_10 (const char *val, double result, int type_error) +{ + to_double_data data; + data.val = scm_c_eval_string (val); + + if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_double_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: scm_double (%s) -> wrong type\n", val); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_double_body, &data, + any_handler, NULL)) + || data.result != result) + { + fprintf (stderr, + "fail: scm_to_double (%s) = %g\n", val, result); + exit (EXIT_FAILURE); + } + } +} + +static void +test_to_double () +{ + test_10 ("#f", 0.0, 1); + test_10 ("12", 12.0, 0); + test_10 ("0.25", 0.25, 0); + test_10 ("1/4", 0.25, 0); + test_10 ("+inf.0", guile_Inf, 0); + test_10 ("-inf.0",-guile_Inf, 0); + test_10 ("+1i", 0.0, 1); +} + +typedef struct { + SCM val; + char *result; +} to_locale_string_data; + +static SCM +to_locale_string_body (void *data) +{ + to_locale_string_data *d = (to_locale_string_data *)data; + d->result = scm_to_locale_string (d->val); + return SCM_BOOL_F; +} + +static void +test_11 (const char *str, const char *result, int misc_error, int type_error) +{ + to_locale_string_data data; + data.val = scm_c_eval_string (str); + data.result = NULL; + + if (misc_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + misc_error_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) -> misc error\n", str); + exit (EXIT_FAILURE); + } + } + else if (type_error) + { + if (scm_is_false (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + wrong_type_handler, NULL))) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) -> wrong type\n", str); + exit (EXIT_FAILURE); + } + } + else + { + if (scm_is_true (scm_internal_catch (SCM_BOOL_T, + to_locale_string_body, &data, + any_handler, NULL)) + || data.result == NULL || strcmp (data.result, result)) + { + fprintf (stderr, + "fail: scm_to_locale_string (%s) = %s\n", str, result); + exit (EXIT_FAILURE); + } + } + + free (data.result); +} + +static void +test_locale_strings () +{ + const char *lstr = "This is not a string."; + char *lstr2; + SCM str, str2; + char buf[20]; + size_t len; + + if (!scm_is_string (scm_c_eval_string ("\"foo\""))) + { + fprintf (stderr, "fail: scm_is_string (\"foo\") = true\n"); + exit (EXIT_FAILURE); + } + + str = scm_from_locale_string (lstr); + + if (!scm_is_string (str)) + { + fprintf (stderr, "fail: scm_is_string (str) = true\n"); + exit (EXIT_FAILURE); + } + + lstr2 = scm_to_locale_string (str); + if (strcmp (lstr, lstr2)) + { + fprintf (stderr, "fail: lstr = lstr2\n"); + exit (EXIT_FAILURE); + } + free (lstr2); + + buf[15] = 'x'; + len = scm_to_locale_stringbuf (str, buf, 15); + if (len != strlen (lstr)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = strlen(lstr)\n"); + exit (EXIT_FAILURE); + } + if (buf[15] != 'x') + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n"); + exit (EXIT_FAILURE); + } + if (strncmp (lstr, buf, 15)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n"); + exit (EXIT_FAILURE); + } + + str2 = scm_from_locale_stringn (lstr, 10); + + if (!scm_is_string (str2)) + { + fprintf (stderr, "fail: scm_is_string (str2) = true\n"); + exit (EXIT_FAILURE); + } + + lstr2 = scm_to_locale_string (str2); + if (strncmp (lstr, lstr2, 10)) + { + fprintf (stderr, "fail: lstr = lstr2\n"); + exit (EXIT_FAILURE); + } + free (lstr2); + + buf[10] = 'x'; + len = scm_to_locale_stringbuf (str2, buf, 20); + if (len != 10) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = 10\n"); + exit (EXIT_FAILURE); + } + if (buf[10] != 'x') + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) no overrun\n"); + exit (EXIT_FAILURE); + } + if (strncmp (lstr, buf, 10)) + { + fprintf (stderr, "fail: scm_to_locale_stringbuf (...) = lstr\n"); + exit (EXIT_FAILURE); + } + + lstr2 = scm_to_locale_stringn (str2, &len); + if (len != 10) + { + fprintf (stderr, "fail: scm_to_locale_stringn, len = 10\n"); + exit (EXIT_FAILURE); + } + + test_11 ("#f", NULL, 0, 1); + test_11 ("\"foo\"", "foo", 0, 0); + test_11 ("(string #\\f #\\nul)", NULL, 1, 0); +} + +static void +test_to_utf8_stringn () +{ + scm_t_wchar wstr[] = { 0x20, /* 0x20 */ + 0xDF, /* 0xC3, 0x9F */ + 0x65E5, /* 0xE6, 0x97, 0xA5 */ + 0x1D400 }; /* 0xF0, 0x9D, 0x90, 0x80 */ + + SCM str0 = scm_from_utf32_stringn (wstr, 1); /* ASCII */ + SCM str1 = scm_from_utf32_stringn (wstr, 2); /* Narrow */ + SCM str2 = scm_from_utf32_stringn (wstr, 4); /* Wide */ + + char cstr0[] = { 0x20, 0 }; + char cstr1[] = { 0x20, 0xC3, 0x9F, 0 }; + char cstr2[] = { 0x20, 0xC3, 0x9F, 0xE6, 0x97, 0xA5, + 0xF0, 0x9D, 0x90, 0x80, 0 }; + char *cstr; + size_t len; + + /* Test conversion of ASCII string */ + cstr = scm_to_utf8_stringn (str0, &len); + if (len + 1 != sizeof (cstr0) || memcmp (cstr, cstr0, len)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, &len)"); + exit (EXIT_FAILURE); + } + free (cstr); + cstr = scm_to_utf8_stringn (str0, NULL); + if (memcmp (cstr, cstr0, len + 1)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<ASCII>, NULL)"); + exit (EXIT_FAILURE); + } + free (cstr); + + /* Test conversion of narrow string */ + cstr = scm_to_utf8_stringn (str1, &len); + if (len + 1 != sizeof (cstr1) || memcmp (cstr, cstr1, len)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, &len)"); + exit (EXIT_FAILURE); + } + free (cstr); + cstr = scm_to_utf8_stringn (str1, NULL); + if (memcmp (cstr, cstr1, len + 1)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<NARROW>, NULL)"); + exit (EXIT_FAILURE); + } + free (cstr); + + /* Test conversion of wide string */ + cstr = scm_to_utf8_stringn (str2, &len); + if (len + 1 != sizeof (cstr2) || memcmp (cstr, cstr2, len)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, &len)"); + exit (EXIT_FAILURE); + } + free (cstr); + cstr = scm_to_utf8_stringn (str2, NULL); + if (memcmp (cstr, cstr2, len + 1)) + { + fprintf (stderr, "fail: scm_to_utf8_stringn (<WIDE>, NULL)"); + exit (EXIT_FAILURE); + } + free (cstr); +} + +static void +test_is_exact () +{ + if (1 != scm_is_exact (scm_c_eval_string ("3"))) + { + fprintf (stderr, "fail: scm_is_exact (\"3\") = 1\n"); + exit (EXIT_FAILURE); + } + if (0 != scm_is_exact (scm_c_eval_string ("3.0"))) + { + fprintf (stderr, "fail: scm_is_exact (\"3.0\") = 0\n"); + exit (EXIT_FAILURE); + } +} + +static void +test_is_inexact () +{ + if (1 !=scm_is_inexact (scm_c_eval_string ("3.0"))) + { + fprintf (stderr, "fail: scm_is_inexact (\"3.0\") = 1\n"); + exit (EXIT_FAILURE); + } + if (0 != scm_is_inexact (scm_c_eval_string ("3"))) + { + fprintf (stderr, "fail: scm_is_inexact (\"3\") = 0\n"); + exit (EXIT_FAILURE); + } +} + + +static void +tests (void *data, int argc, char **argv) +{ + test_is_signed_integer (); + test_is_unsigned_integer (); + test_to_signed_integer (); + test_to_unsigned_integer (); + test_from_signed_integer (); + test_from_unsigned_integer (); + test_int_sizes (); + test_from_double (); + test_to_double (); + test_locale_strings (); + test_to_utf8_stringn (); + test_is_exact (); + test_is_inexact (); +} + +int +main (int argc, char *argv[]) +{ + ieee_init (); + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-extensions b/test-suite/standalone/test-extensions new file mode 100755 index 000000000..ec320113b --- /dev/null +++ b/test-suite/standalone/test-extensions @@ -0,0 +1,16 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +(load-extension (string-append (getenv "builddir") "/libtest-extensions") + "libtest_extensions_init") +(load-extension (string-append (getenv "builddir") "/libtest-extensions") + "libtest_extensions_init2") + +(or (= init2-count 1) + (error "init2 called more or less than one time")) + + +;; Local Variables: +;; mode: scheme +;; End:
\ No newline at end of file diff --git a/test-suite/standalone/test-extensions-lib.c b/test-suite/standalone/test-extensions-lib.c new file mode 100644 index 000000000..84eb376b9 --- /dev/null +++ b/test-suite/standalone/test-extensions-lib.c @@ -0,0 +1,45 @@ +/* Copyright 1999-2001,2003,2006,2008,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +SCM init2_count; + +void libtest_extensions_init2 (void); +void libtest_extensions_init (void); + +void +libtest_extensions_init2 (void) +{ + scm_variable_set_x (init2_count, + scm_from_int (scm_to_int (scm_variable_ref (init2_count)) + 1)); +} + +void +libtest_extensions_init (void) +{ + scm_c_define ("init2-count", scm_from_int (0)); + init2_count = scm_permanent_object (scm_c_lookup ("init2-count")); + scm_c_register_extension ("libtest-extensions", "libtest_extensions_init2", + (scm_t_extension_init_func)libtest_extensions_init2, NULL); +} diff --git a/test-suite/standalone/test-fast-slot-ref.in b/test-suite/standalone/test-fast-slot-ref.in new file mode 100644 index 000000000..e0708ab9d --- /dev/null +++ b/test-suite/standalone/test-fast-slot-ref.in @@ -0,0 +1,40 @@ +#!/bin/sh + +# Copyright (C) 2006 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 + +# Test for %fast-slot-ref, which was previously implemented such that +# an out-of-range slot index could escape being properly detected, and +# could then cause a segmentation fault. +# +# Prior to the change in this commit to goops.c, the following +# sequence reliably causes a segmentation fault on my GNU/Linux when +# executing the (%fast-slot-ref i 3) line. For reasons as yet +# unknown, it does not cause a segmentation fault if the same code is +# loaded as a script; that is why we run it here using "guile -q <<EOF". +exec guile -q >/dev/null 2>&1 <<EOF +(use-modules (oop goops)) +(define-module (oop goops)) +(define-class <c> () (a #:init-value 1) (b #:init-value 2) (c #:init-value 3)) +(define i (make <c>)) +(%fast-slot-ref i 1) +(%fast-slot-ref i 0) +(%fast-slot-ref i 3) +(%fast-slot-ref i -1) +(%fast-slot-ref i 2) +(exit 0) +EOF diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi new file mode 100755 index 000000000..0e6ab45d1 --- /dev/null +++ b/test-suite/standalone/test-ffi @@ -0,0 +1,294 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# +;;; test-ffi --- Foreign function interface. -*- Scheme -*- +;;; +;;; Copyright (C) 2010, 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 + +(use-modules (system foreign) + (rnrs bytevectors) + (srfi srfi-1) + (srfi srfi-26)) + +(define lib + (dynamic-link (string-append (getenv "builddir") "/libtest-ffi"))) + +(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))))))) + +;;; +;;; No args +;;; +(define f-v- + (pointer->procedure void (dynamic-func "test_ffi_v_" lib) '())) +(test (f-v-) *unspecified*) + +(define f-s8- + (pointer->procedure int8 (dynamic-func "test_ffi_s8_" lib) '())) +(test (f-s8-) -100) + +(define f-u8- + (pointer->procedure uint8 (dynamic-func "test_ffi_u8_" lib) '())) +(test (f-u8-) 200) + +(define f-s16- + (pointer->procedure int16 (dynamic-func "test_ffi_s16_" lib) '())) +(test (f-s16-) -20000) + +(define f-u16- + (pointer->procedure uint16 (dynamic-func "test_ffi_u16_" lib) '())) +(test (f-u16-) 40000) + +(define f-s32- + (pointer->procedure int32 (dynamic-func "test_ffi_s32_" lib) '())) +(test (f-s32-) -2000000000) + +(define f-u32- + (pointer->procedure uint32 (dynamic-func "test_ffi_u32_" lib) '())) +(test (f-u32-) 4000000000) + +(define f-s64- + (pointer->procedure int64 (dynamic-func "test_ffi_s64_" lib) '())) +(test (f-s64-) -2000000000) + +(define f-u64- + (pointer->procedure uint64 (dynamic-func "test_ffi_u64_" lib) '())) +(test (f-u64-) 4000000000) + +;;; +;;; One u8 arg +;;; +(define f-v-u8 + (pointer->procedure void (dynamic-func "test_ffi_v_u8" lib) (list uint8))) +(test (f-v-u8 10) *unspecified*) + +(define f-s8-u8 + (pointer->procedure int8 (dynamic-func "test_ffi_s8_u8" lib) (list uint8))) +(test (f-s8-u8 10) -90) + +(define f-u8-u8 + (pointer->procedure uint8 (dynamic-func "test_ffi_u8_u8" lib) (list uint8))) +(test (f-u8-u8 10) 210) + +(define f-s16-u8 + (pointer->procedure int16 (dynamic-func "test_ffi_s16_u8" lib) (list uint8))) +(test (f-s16-u8 10) -19990) + +(define f-u16-u8 + (pointer->procedure uint16 (dynamic-func "test_ffi_u16_u8" lib) (list uint8))) +(test (f-u16-u8 10) 40010) + +(define f-s32-u8 + (pointer->procedure int32 (dynamic-func "test_ffi_s32_u8" lib) (list uint8))) +(test (f-s32-u8 10) -1999999990) + +(define f-u32-u8 + (pointer->procedure uint32 (dynamic-func "test_ffi_u32_u8" lib) (list uint8))) +(test (f-u32-u8 10) 4000000010) + +(define f-s64-u8 + (pointer->procedure int64 (dynamic-func "test_ffi_s64_u8" lib) (list uint8))) +(test (f-s64-u8 10) -1999999990) + +(define f-u64-u8 + (pointer->procedure uint64 (dynamic-func "test_ffi_u64_u8" lib) (list uint8))) +(test (f-u64-u8 10) 4000000010) + + +;;; +;;; One s64 arg +;;; +(define f-v-s64 + (pointer->procedure void (dynamic-func "test_ffi_v_s64" lib) (list int64))) +(test (f-v-s64 10) *unspecified*) + +(define f-s8-s64 + (pointer->procedure int8 (dynamic-func "test_ffi_s8_s64" lib) (list int64))) +(test (f-s8-s64 10) -90) + +(define f-u8-s64 + (pointer->procedure uint8 (dynamic-func "test_ffi_u8_s64" lib) (list int64))) +(test (f-u8-s64 10) 210) + +(define f-s16-s64 + (pointer->procedure int16 (dynamic-func "test_ffi_s16_s64" lib) (list int64))) +(test (f-s16-s64 10) -19990) + +(define f-u16-s64 + (pointer->procedure uint16 (dynamic-func "test_ffi_u16_s64" lib) (list int64))) +(test (f-u16-s64 10) 40010) + +(define f-s32-s64 + (pointer->procedure int32 (dynamic-func "test_ffi_s32_s64" lib) (list int64))) +(test (f-s32-s64 10) -1999999990) + +(define f-u32-s64 + (pointer->procedure uint32 (dynamic-func "test_ffi_u32_s64" lib) (list int64))) +(test (f-u32-s64 10) 4000000010) + +(define f-s64-s64 + (pointer->procedure int64 (dynamic-func "test_ffi_s64_s64" lib) (list int64))) +(test (f-s64-s64 10) -1999999990) + +(define f-u64-s64 + (pointer->procedure uint64 (dynamic-func "test_ffi_u64_s64" lib) (list int64))) +(test (f-u64-s64 10) 4000000010) + + +;; +;; Multiple int args of differing types +;; +(define f-sum + (pointer->procedure int64 (dynamic-func "test_ffi_sum" lib) + (list int8 int16 int32 int64))) +(test (f-sum -1 2000 -30000 40000000000) + (+ -1 2000 -30000 40000000000)) + +;; +;; More than ten arguments +;; +(define f-sum-many + (pointer->procedure int64 (dynamic-func "test_ffi_sum_many" lib) + (list uint8 uint16 uint32 uint64 + int8 int16 int32 int64 + int8 int16 int32 int64))) +(test (f-sum-many 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000) + (+ 255 65535 4294967295 1844674407370955161 + -1 2000 -30000 40000000000 + 5 -6000 70000 -80000000000)) + +;; +;; Structs +;; +(define f-sum-struct + (pointer->procedure int64 (dynamic-func "test_ffi_sum_struct" lib) + (list (list int8 int16 int32 int64)))) +(test (f-sum-struct (make-c-struct (list int8 int16 int32 int64) + (list -1 2000 -30000 40000000000))) + (+ -1 2000 -30000 40000000000)) +;; +;; Structs +;; +(define f-memcpy + (pointer->procedure '* (dynamic-func "test_ffi_memcpy" lib) + (list '* '* int32))) +(let* ((src* '(0 1 2 3 4 5 6 7)) + (src (bytevector->pointer (u8-list->bytevector src*))) + (dest (bytevector->pointer (make-bytevector 16 0))) + (res (f-memcpy dest src (length src*)))) + (or (= (pointer-address dest) (pointer-address res)) + (error "memcpy res not equal to dest")) + (or (equal? (bytevector->u8-list (pointer->bytevector dest 16)) + '(0 1 2 3 4 5 6 7 0 0 0 0 0 0 0 0)) + (error "unexpected dest"))) + +;; +;; Function pointers +;; + +(define f-callback-1 + (pointer->procedure int (dynamic-func "test_ffi_callback_1" lib) + (list '* int))) + +(if (defined? 'procedure->pointer) + (let* ((calls 0) + (ptr (procedure->pointer int + (lambda (x) + (set! calls (+ 1 calls)) + (* x 3)) + (list int))) + (input (iota 123))) + (define (expected-result x) + (+ 7 (* x 3))) + + (let ((result (map (cut f-callback-1 ptr <>) input))) + (and (or (= calls (length input)) + (error "incorrect number of callback calls" calls)) + (or (equal? (map expected-result input) result) + (error "incorrect result" result)))))) + +(define f-callback-2 + (pointer->procedure double (dynamic-func "test_ffi_callback_2" lib) + (list '* float int double))) + +(if (defined? 'procedure->pointer) + (let* ((proc (lambda (x y z) + (* (+ x (exact->inexact y)) z))) + (ptr (procedure->pointer double proc + (list float int double))) + (arg1 (map (cut * <> 1.25) (iota 123 500))) + (arg2 (iota 123)) + (arg3 (map (cut / <> 2.0) (iota 123 0 -10)))) + (define result + (map (cut f-callback-2 ptr <> <> <>) + arg1 arg2 arg3)) + + (or (equal? result (map proc arg1 arg2 arg3)) + (error "incorrect result" result)))) + + +;;; +;;; Global symbols. +;;; + +(use-modules ((rnrs bytevectors) #:select (utf8->string))) + +(if (defined? 'setlocale) + (setlocale LC_ALL "C")) + +(define global (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, dynamic-link doesn't search recursively + ;; into linked DLLs. Thus one needs to link to the core + ;; C library DLL explicitly. + (dynamic-link "cygwin1")) + (else + (dynamic-link)))) + + +(define strerror + (pointer->procedure '* (dynamic-func "strerror" global) + (list int))) + +(define strlen + (pointer->procedure size_t (dynamic-func "strlen" global) + (list '*))) + +(let* ((ptr (strerror ENOENT)) + (len (strlen ptr)) + (bv (pointer->bytevector ptr len 0 'u8)) + (str (utf8->string bv))) + (test #t (not (not (string-contains str "file"))))) + +(exit (not failed?)) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-ffi-lib.c b/test-suite/standalone/test-ffi-lib.c new file mode 100644 index 000000000..cdfefd84a --- /dev/null +++ b/test-suite/standalone/test-ffi-lib.c @@ -0,0 +1,249 @@ +/* Copyright 2010-2011,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> + +#include <libguile.h> + +void test_ffi_v_ (void); +void test_ffi_v_ (void) +{ + return; +} + +void test_ffi_v_u8 (uint8_t a); +void test_ffi_v_u8 (uint8_t a) +{ + return; +} + +void test_ffi_v_s64 (int64_t a); +void test_ffi_v_s64 (int64_t a) +{ + return; +} + +int8_t test_ffi_s8_ (void); +int8_t test_ffi_s8_ (void) +{ + return -100; +} +int8_t test_ffi_s8_u8 (uint8_t a); +int8_t test_ffi_s8_u8 (uint8_t a) +{ + return -100 + a; +} + +int8_t test_ffi_s8_s64 (int64_t a); +int8_t test_ffi_s8_s64 (int64_t a) +{ + return -100 + a; +} + +uint8_t test_ffi_u8_ (void); +uint8_t test_ffi_u8_ (void) +{ + return 200; +} + +uint8_t test_ffi_u8_u8 (uint8_t a); +uint8_t test_ffi_u8_u8 (uint8_t a) +{ + return 200 + a; +} + +uint8_t test_ffi_u8_s64 (int64_t a); +uint8_t test_ffi_u8_s64 (int64_t a) +{ + return 200 + a; +} + +int16_t test_ffi_s16_ (void); +int16_t test_ffi_s16_ (void) +{ + return -20000; +} + +int16_t test_ffi_s16_u8 (uint8_t a); +int16_t test_ffi_s16_u8 (uint8_t a) +{ + return -20000 + a; +} + +int16_t test_ffi_s16_s64 (int64_t a); +int16_t test_ffi_s16_s64 (int64_t a) +{ + return -20000 + a; +} + +uint16_t test_ffi_u16_ (void); +uint16_t test_ffi_u16_ (void) +{ + return 40000; +} + +uint16_t test_ffi_u16_u8 (uint8_t a); +uint16_t test_ffi_u16_u8 (uint8_t a) +{ + return 40000 + a; +} + +uint16_t test_ffi_u16_s64 (int64_t a); +uint16_t test_ffi_u16_s64 (int64_t a) +{ + return 40000 + a; +} + +int32_t test_ffi_s32_ (void); +int32_t test_ffi_s32_ (void) +{ + return -2000000000; +} + +int32_t test_ffi_s32_u8 (uint8_t a); +int32_t test_ffi_s32_u8 (uint8_t a) +{ + return -2000000000 + a; +} + +int32_t test_ffi_s32_s64 (int64_t a); +int32_t test_ffi_s32_s64 (int64_t a) +{ + return -2000000000 + a; +} + +uint32_t test_ffi_u32_ (void); +uint32_t test_ffi_u32_ (void) +{ + return 4000000000U; +} + +uint32_t test_ffi_u32_u8 (uint8_t a); +uint32_t test_ffi_u32_u8 (uint8_t a) +{ + return 4000000000U + a; +} + +uint32_t test_ffi_u32_s64 (int64_t a); +uint32_t test_ffi_u32_s64 (int64_t a) +{ + return 4000000000U + a; +} + +/* FIXME: use 64-bit literals */ +int64_t test_ffi_s64_ (void); +int64_t test_ffi_s64_ (void) +{ + return -2000000000; +} + +int64_t test_ffi_s64_u8 (uint8_t a); +int64_t test_ffi_s64_u8 (uint8_t a) +{ + return -2000000000 + a; +} + +int64_t test_ffi_s64_s64 (int64_t a); +int64_t test_ffi_s64_s64 (int64_t a) +{ + return -2000000000 + a; +} + +uint64_t test_ffi_u64_ (void); +uint64_t test_ffi_u64_ (void) +{ + return 4000000000UL; +} + +uint64_t test_ffi_u64_u8 (uint8_t a); +uint64_t test_ffi_u64_u8 (uint8_t a) +{ + return 4000000000UL + a; +} + +uint64_t test_ffi_u64_s64 (int64_t a); +uint64_t test_ffi_u64_s64 (int64_t a) +{ + return 4000000000UL + a; +} + + +int64_t test_ffi_sum (int8_t a, int16_t b, + int32_t c, int64_t d); +int64_t test_ffi_sum (int8_t a, int16_t b, + int32_t c, int64_t d) +{ + return d + c + b + a; +} + + +int64_t test_ffi_sum_many (uint8_t a, uint16_t b, + uint32_t c, uint64_t d, + int8_t e, int16_t f, + int32_t g, int64_t h, + int8_t i, int16_t j, + int32_t k, int64_t l); +int64_t test_ffi_sum_many (uint8_t a, uint16_t b, + uint32_t c, uint64_t d, + int8_t e, int16_t f, + int32_t g, int64_t h, + int8_t i, int16_t j, + int32_t k, int64_t l) +{ + return l + k + j + i + h + g + f + e + d + c + b + a; +} + + +struct foo +{ + int8_t a; + int16_t b; + int32_t c; + int64_t d; +}; +int64_t test_ffi_sum_struct (struct foo foo); +int64_t test_ffi_sum_struct (struct foo foo) +{ + return foo.d + foo.c + foo.b + foo.a; +} + + +void* test_ffi_memcpy (void *dest, void *src, int32_t n); +void* test_ffi_memcpy (void *dest, void *src, int32_t n) +{ + return memcpy (dest, src, n); +} + +int test_ffi_callback_1 (int (*f) (int), int x); +int test_ffi_callback_1 (int (*f) (int), int x) +{ + return f (x) + 7; +} + +double test_ffi_callback_2 (double (*f) (float, int, double), + float x, int y, double z); +double test_ffi_callback_2 (double (*f) (float, int, double), + float x, int y, double z) +{ + return f (x, y, z); +} 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..00c997a56 --- /dev/null +++ b/test-suite/standalone/test-foreign-object-c.c @@ -0,0 +1,116 @@ +/* test-foreign-object-c.c - exercise C foreign object interface */ + +/* Copyright 2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#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..fd4669aa9 --- /dev/null +++ b/test-suite/standalone/test-foreign-object-scm @@ -0,0 +1,129 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# +;;; test-foreign-object-scm --- Foreign object interface. -*- Scheme -*- +;;; +;;; Copyright (C) 2014, 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 + +(use-modules (system foreign) + (system foreign-object) + (rnrs bytevectors) + (oop goops)) + +(define (libc-ptr name) + (catch #t + (lambda () + (dynamic-pointer name + (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))))) + (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/standalone/test-guild-compile b/test-suite/standalone/test-guild-compile new file mode 100755 index 000000000..5972d5474 --- /dev/null +++ b/test-suite/standalone/test-guild-compile @@ -0,0 +1,47 @@ +#!/bin/sh +# +# This -*- sh -*- script tests whether 'guild compile' leaves traces +# behind it upon SIGINT. + +source="t-guild-compile-$$" +target="$source.go" + +trap 'rm -f "$source" "$target"' EXIT + +cat > "$source"<<EOF +(eval-when (expand load eval) + ;; Wait for SIGINT. + (pause) + + ;; Then sleep so that the SIGINT handler gets to run + ;; and compilation doesn't complete before it runs. + (sleep 100)) +(define chbouib 42) +EOF + +guild compile -o "$target" "$source" & +pid="$!" + +# Send SIGINT. +sleep 2 && kill -INT "$pid" + +# Wait for 'guild compile' to terminate. +sleep 2 + +# Check whether there are any leftovers. +for file in "$target"* +do + if test "$file" != "${target}*" + then + echo "error: 'guild compile' failed to remove '$file'" >&2 + rm "$target"* + kill "$pid" + exit 1 + fi +done + +if test -f "$target" +then + echo "error: '$target' produced" >&2 + exit 1 +fi diff --git a/test-suite/standalone/test-guile-snarf b/test-suite/standalone/test-guile-snarf new file mode 100755 index 000000000..e31479149 --- /dev/null +++ b/test-suite/standalone/test-guile-snarf @@ -0,0 +1,38 @@ +#!/bin/sh + +# Test the `guile-snarf' tool. + +# Strip the first line, like GNU `tail -n +2' does, but in a portable +# way (`tail' on Solaris 10 doesn't support `-n +2' for instance.) +strip_first_line () +{ + read line + while read line + do + echo "$line" + done +} + +snarf () +{ + # GNU cpp emits a comment on the first line, which shows what + # arguments it was passed. Strip this line. + echo "$1" | guile-snarf - | strip_first_line | tr -d ' \t\n' +} + +snarf_test () +{ + x=`snarf "$1"` + if [ x"$x" != x"$2" ]; then + echo "Incorrect output: expected \"$2\", but got \"$x\"" + exit 1 + fi +} + +snarf_test "^^a^:^" "a;" +snarf_test " ^ ^ b ^ : ^ " "b;" +snarf_test "c\n^^d^:^\ne" "d;" +snarf_test "f^^g^:^h" "g;" +snarf_test "^^i^:^j^^k^:^" "i;k;" +snarf_test "l^^m" "" +snarf_test "n^:^o" "" diff --git a/test-suite/standalone/test-import-order b/test-suite/standalone/test-import-order new file mode 100755 index 000000000..8b51312a9 --- /dev/null +++ b/test-suite/standalone/test-import-order @@ -0,0 +1,31 @@ +#!/bin/sh +exec guile -q -L "$srcdir" -s "$0" "$@" +!# + +(define-module (base) + #:export (push! order)) + +(define order '()) +(define (push!) + (set! order `(,@order ,(module-name (current-module))))) + +(define-module (test-1) + #:use-module (base) + #:use-module (test-import-order-a) + #:use-module (test-import-order-b)) + +(use-modules (test-import-order-c) (test-import-order-d)) + +(if (not (equal? order + '((test-import-order-a) + (test-import-order-b) + (test-import-order-c) + (test-import-order-d)))) + (begin + (format (current-error-port) "Unexpected import order: ~a" order) + (exit 1)) + (exit 0)) + +;; Local Variables: +;; mode: scheme +;; End:
\ No newline at end of file diff --git a/test-suite/standalone/test-import-order-a.scm b/test-suite/standalone/test-import-order-a.scm new file mode 100644 index 000000000..d6fa29def --- /dev/null +++ b/test-suite/standalone/test-import-order-a.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-a) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-b.scm b/test-suite/standalone/test-import-order-b.scm new file mode 100644 index 000000000..bc41bdf9f --- /dev/null +++ b/test-suite/standalone/test-import-order-b.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-b) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-c.scm b/test-suite/standalone/test-import-order-c.scm new file mode 100644 index 000000000..4b58c3d75 --- /dev/null +++ b/test-suite/standalone/test-import-order-c.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-c) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-import-order-d.scm b/test-suite/standalone/test-import-order-d.scm new file mode 100644 index 000000000..fb071be93 --- /dev/null +++ b/test-suite/standalone/test-import-order-d.scm @@ -0,0 +1,4 @@ +(define-module (test-import-order-d) + #:use-module (base)) + +(push!) diff --git a/test-suite/standalone/test-language b/test-suite/standalone/test-language new file mode 100755 index 000000000..d67d36129 --- /dev/null +++ b/test-suite/standalone/test-language @@ -0,0 +1,27 @@ +#!/bin/sh + +set -e + +# Make sure that code passed as `-c' or `-l' is evaluted using the +# right language. + +# The default language in effect until `--language' is encountered is +# Scheme. +guile -c "(exit (= 3 (apply + '(1 2))))" --language=elisp + +if guile -c "(= (funcall (symbol-function '+) 1 2) 3)" 2> /dev/null +then false; else true; fi + +guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)" +guile --language=ecmascript -c '(function (x) { return x * x; })(2);' + +# Same with `-l'. +guile --no-auto-compile -l "$top_srcdir/module/ice-9/q.scm" -c 1 +guile --no-auto-compile \ + -l "$top_srcdir/module/ice-9/q.scm" \ + --language=elisp \ + -l "$srcdir/test-language.el" \ + --language=ecmascript \ + -l "$srcdir/test-language.js" \ + --language=scheme \ + -c 1 diff --git a/test-suite/standalone/test-language.el b/test-suite/standalone/test-language.el new file mode 100644 index 000000000..c1f09cc3f --- /dev/null +++ b/test-suite/standalone/test-language.el @@ -0,0 +1,11 @@ +;; Sample Elisp code for `test-language'. + +(defun fib (n) + "Anything but a fib." + (if (<= n 1) + n + (+ (fib (- n 1)) + (fib (- n 2))))) + +(or (= 13 (fib 7)) + (error "Something's wrong!")) diff --git a/test-suite/standalone/test-language.js b/test-suite/standalone/test-language.js new file mode 100644 index 000000000..c8de366cc --- /dev/null +++ b/test-suite/standalone/test-language.js @@ -0,0 +1,12 @@ +/* Sample ECMAscript code for `test-language'. */ + +function fib (n) +{ + if (n <= 1) + return n; + else + return fib (n - 1) + fib (n - 2); +} + +if (fib (7) != 13) + error ("Something's wrong!"); diff --git a/test-suite/standalone/test-list.c b/test-suite/standalone/test-list.c new file mode 100644 index 000000000..b0158b7c7 --- /dev/null +++ b/test-suite/standalone/test-list.c @@ -0,0 +1,66 @@ +/* test-list.c - exercise libguile/list.c functions */ + +/* Copyright 2006,2008-2010,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +/* pretty trivial, but ensure this entrypoint exists, since it was + documented in Guile 1.6 and earlier */ +static void +test_scm_list (void) +{ + { + if (! scm_is_eq (SCM_EOL, scm_list (SCM_EOL))) + { + fprintf (stderr, "fail: scm_list SCM_EOL\n"); + exit (EXIT_FAILURE); + } + } + + { + SCM lst = scm_list_2 (scm_from_int (1), scm_from_int (2)); + if (! scm_is_true (scm_equal_p (lst, scm_list (lst)))) + { + fprintf (stderr, "fail: scm_list '(1 2)\n"); + exit (EXIT_FAILURE); + } + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_list (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-loose-ends.c b/test-suite/standalone/test-loose-ends.c new file mode 100644 index 000000000..40209ab75 --- /dev/null +++ b/test-suite/standalone/test-loose-ends.c @@ -0,0 +1,110 @@ +/* test-loose-ends.c + * + * Test items of the Guile C API that aren't covered by any other tests. + */ + +/* Copyright 2009,2012,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <libguile.h> + +#include <stdio.h> +#include <assert.h> +#include <string.h> + +#ifdef HAVE_INTTYPES_H +# include <inttypes.h> +#endif + +static void +test_scm_from_locale_keywordn () +{ + SCM kw = scm_from_locale_keywordn ("thusly", 4); + assert (scm_is_true (scm_keyword_p (kw))); +} + +static void +test_scm_local_eval () +{ + SCM result; + + scm_c_use_module ("ice-9 local-eval"); + result = scm_local_eval + (scm_list_3 (scm_from_latin1_symbol ("+"), + scm_from_latin1_symbol ("x"), + scm_from_latin1_symbol ("y")), + scm_c_eval_string ("(let ((x 1) (y 2)) (the-environment))")); + + assert (scm_is_true (scm_equal_p (result, + scm_from_signed_integer (3)))); +} + +static void +test_scm_call () +{ + SCM result; + + result = scm_call (scm_c_public_ref ("guile", "+"), + scm_from_int (1), + scm_from_int (2), + SCM_UNDEFINED); + assert (scm_is_true (scm_equal_p (result, scm_from_int (3)))); + + result = scm_call (scm_c_public_ref ("guile", "list"), + SCM_UNDEFINED); + assert (scm_is_eq (result, SCM_EOL)); +} + +static void +test_scm_to_pointer () +{ + int (*add3) (int a, int b, int c); + SCM int_type = scm_c_public_ref ("system foreign", "int"); + + add3 = scm_to_pointer + (scm_procedure_to_pointer (int_type, + scm_c_public_ref ("guile", "+"), + scm_list_3 (int_type, + int_type, + int_type))); + + assert ((*add3) (1000000, 1000, -1) == 1000999); +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_from_locale_keywordn (); + test_scm_local_eval (); + test_scm_call (); + test_scm_to_pointer (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-mb-regexp b/test-suite/standalone/test-mb-regexp new file mode 100755 index 000000000..b0cca69a2 --- /dev/null +++ b/test-suite/standalone/test-mb-regexp @@ -0,0 +1,39 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# +;;; test-mb-regexp --- A multibyte regexp test +;;; +;;; Copyright (C) 2010, 2011 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 + +;; This test depends on not setting the locale -- that multibyte strings +;; don't trigger the abort in regexp.c:fixup_multibyte_match. + +(use-modules (ice-9 regex)) + +(exit (if (equal? + (match:substring + (regexp-exec + (make-regexp "(.)(.)(.)") + (string (integer->char 200) #\x (integer->char 202))) + 2) + "x") + 0 + 1)) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c new file mode 100644 index 000000000..25db4de62 --- /dev/null +++ b/test-suite/standalone/test-num2integral.c @@ -0,0 +1,156 @@ +/* Copyright 1999-2001,2003-2004,2006,2008,2010-2012,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <libguile.h> + +#include <stdio.h> +#include <assert.h> +#include <limits.h> + +SCM out_of_range_handler (void *data, SCM key, SCM args); +SCM call_num2long_long_body (void *data); +SCM call_num2ulong_long_body (void *data); + +/* expect to catch an `out-of-range' exception */ +SCM +out_of_range_handler (void *data, SCM key, SCM args) +{ + assert (scm_is_eq (key, scm_from_locale_symbol ("out-of-range"))); + return SCM_BOOL_T; +} + +SCM +call_num2long_long_body (void *data) +{ + scm_to_long_long (* (SCM *) data); + return SCM_BOOL_F; +} + +SCM +call_num2ulong_long_body (void *data) +{ + scm_to_ulong_long (* (SCM *) data); + return SCM_BOOL_F; +} + +static void +test_long_long () +{ + { + SCM n = scm_from_long_long (LLONG_MIN); + long long result = scm_to_long_long(n); + assert (result == LLONG_MIN); + } + + /* LLONG_MIN - 1 */ + { + SCM n = scm_difference (scm_from_long_long (LLONG_MIN), scm_from_int (1)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */ + { + SCM n = scm_sum (scm_from_long_long (LLONG_MIN), + scm_from_long_long (LLONG_MIN / 2)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* SCM_I_LLONG_MAX + 1 */ + { + SCM n = scm_sum (scm_from_long_long (LLONG_MAX), scm_from_int (1)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* 2^1024 */ + { + SCM n = scm_ash (scm_from_int (1), scm_from_int (1024)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* -2^1024 */ + { + SCM n = scm_difference (scm_from_int (0), + scm_ash (scm_from_int (1), scm_from_int (1024))); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } +} + +static void +test_ulong_long () +{ + { + SCM n = scm_from_ulong_long (ULLONG_MAX); + unsigned long long result = scm_to_ulong_long(n); + assert (result == ULLONG_MAX); + } + + /* -1 */ + { + SCM n = scm_from_int (-1); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* SCM_I_ULLONG_MAX + 1 */ + { + SCM n = scm_sum (scm_from_ulong_long (ULLONG_MAX), scm_from_int (1)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } + + /* 2^1024 */ + { + SCM n = scm_ash (scm_from_int (1), scm_from_int (1024)); + SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n, + out_of_range_handler, NULL); + assert (scm_is_true (caught)); + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_long_long (); + test_ulong_long (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-out-of-memory b/test-suite/standalone/test-out-of-memory new file mode 100755 index 000000000..221651270 --- /dev/null +++ b/test-suite/standalone/test-out-of-memory @@ -0,0 +1,83 @@ +#!/bin/sh +guild compile "$0" +exec guile -q -s "$0" "$@" +!# + +(unless (defined? 'setrlimit) + ;; Without an rlimit, this test can take down your system, as it + ;; consumes all of your memory. That doesn't seem like something we + ;; should run as part of an automated test suite. + (exit 0)) + +(when (string-ci= "darwin" (vector-ref (uname) 0)) + ;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding + ;; with the test would fill all available memory and probably end in a crash. + ;; See also test-stack-overflow. + (exit 77)) ; unresolved + +(when (string-ci= "GNU" (vector-ref (uname) 0)) + ;; setrlimits are not yet implemented on GNU/Hurd systems. Proceeding + ;; with the test would end in a crash. See + ;; <https://lists.gnu.org/archive/html/bug-hurd/2017-05/msg00013.html> + (exit 77)) ; unresolved + +(when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") + ;; attempting to use setrlimits for memory RLIMIT_AS will always + ;; produce an invalid argument error on Cygwin (tested on + ;; CYGWIN_NT-10.0 DLL v2.7.0). Proceeding with the test would fill + ;; all available memory and probably end in a crash. See also + ;; test-stack-overflow. + (exit 77)) ; unresolved + +(catch #t + ;; Silence GC warnings. + (lambda () + (current-warning-port (open-output-file "/dev/null"))) + (lambda (k . args) + (print-exception (current-error-port) #f k args) + (write "Skipping test.\n" (current-error-port)) + (exit 0))) + +;; 50 MB. +(define *limit* (* 50 1024 1024)) + +(call-with-values (lambda () (getrlimit 'as)) + (lambda (soft hard) + (unless (and soft (< soft *limit*)) + (setrlimit 'as (if hard (min *limit* hard) *limit*) hard)))) + +(define (test thunk) + (catch 'out-of-memory + (lambda () + (thunk) + (error "should not be reached")) + (lambda _ + #t))) + +(use-modules (rnrs bytevectors)) + +(test (lambda () + ;; Unhappily, on 32-bit systems, vectors are limited to 16M + ;; elements. Boo. Anyway, a vector with 16M elements takes 64 + ;; MB, which doesn't fit into 50 MB. + (make-vector (1- (ash 1 24))))) +(test (lambda () + ;; Likewise for a bytevector. This is different from the above, + ;; as the elements of a bytevector are not traced by GC. + (make-bytevector #e1e9))) +(test (lambda () + ;; This one is the kicker -- we allocate pairs until the heap + ;; can't expand. This is the hardest test to deal with because + ;; the error-handling machinery has no memory in which to work. + (iota #e1e8))) +(test (lambda () + ;; The same, but also causing allocating during the unwind + ;; (ouch!) + (dynamic-wind + (lambda () #t) + (lambda () (iota #e1e8)) + (lambda () (iota #e1e8))))) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-pthread-create-secondary.c b/test-suite/standalone/test-pthread-create-secondary.c new file mode 100644 index 000000000..a06668fcc --- /dev/null +++ b/test-suite/standalone/test-pthread-create-secondary.c @@ -0,0 +1,91 @@ +/* Copyright 2011,2013,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Test whether threads created with `pthread_create' work, and whether + a secondary thread can call `scm_with_guile'. (bug #32436). */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <pthread.h> +#include <stdlib.h> +#include <libguile.h> + +#include <gc/gc.h> + + +/* Currently, calling `GC_INIT' from a secondary thread is only + supported on some systems, notably Linux-based systems (and not on + FreeBSD, for instance.) + + Up to GC 7.2alpha5, calling `GC_INIT' from a secondary thread would + lead to a segfault. This was fixed in BDW-GC on 2011-04-16 by Ivan + Maidanski. See <http://thread.gmane.org/gmane.lisp.guile.bugs/5340> + for details. */ + +#if defined __linux__ \ + && (GC_VERSION_MAJOR > 7 \ + || (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR > 2) \ + || (GC_VERSION_MAJOR == 7 && GC_VERSION_MINOR == 2 \ + && GC_ALPHA_VERSION > 5)) + +static void * +do_something (void *arg) +{ + scm_list_copy (scm_make_list (scm_from_int (1234), SCM_BOOL_T)); + scm_gc (); + return NULL; +} + +static void * +thread (void *arg) +{ + scm_with_guile (do_something, NULL); + return NULL; +} + + +int +main (int argc, char *argv[]) +{ + int i; + + for (i = 0; i < 77; i++) + { + pthread_t thr; + + pthread_create (&thr, NULL, thread, NULL); + pthread_join (thr, NULL); + } + + return EXIT_SUCCESS; +} + + +#else /* Linux && GC < 7.2alpha5 */ + +int +main (int argc, char *argv[]) +{ + /* Skip. */ + return 77; +} + +#endif /* GC < 7.2 */ diff --git a/test-suite/standalone/test-pthread-create.c b/test-suite/standalone/test-pthread-create.c new file mode 100644 index 000000000..9fc7af158 --- /dev/null +++ b/test-suite/standalone/test-pthread-create.c @@ -0,0 +1,70 @@ +/* Copyright 2011,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Test whether threads created with `pthread_create' work (bug #32436) + when then main thread is the one that initializes Guile. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <pthread.h> +#include <stdlib.h> +#include <libguile.h> + +static void * +do_something (void *arg) +{ + scm_list_copy (scm_make_list (scm_from_int (1234), SCM_BOOL_T)); + scm_gc (); + return NULL; +} + +static void * +thread (void *arg) +{ + scm_with_guile (do_something, NULL); + return NULL; +} + +static void * +inner_main (void *data) +{ + int i; + pthread_t thr; + + do_something (NULL); + + for (i = 0; i < 77; i++) + { + pthread_create (&thr, NULL, thread, NULL); + pthread_join (thr, NULL); + } + + return NULL; +} + + +int +main (int argc, char *argv[]) +{ + scm_with_guile (inner_main, NULL); + + return EXIT_SUCCESS; +} diff --git a/test-suite/standalone/test-require-extension b/test-suite/standalone/test-require-extension new file mode 100755 index 000000000..69f18589a --- /dev/null +++ b/test-suite/standalone/test-require-extension @@ -0,0 +1,18 @@ +#!/bin/sh + +set -e + +# expect these to throw errors, if they succeed it's wrong +# +# (Note the syntax "! guile -c ..." isn't used here, because that doesn't +# work on Solaris 10.) +# +guile -q -c '(require-extension 7)' 2>/dev/null && exit 1 +guile -q -c '(require-extension (blarg))' 2>/dev/null && exit 1 +guile -q -c '(require-extension (srfi "foo"))' 2>/dev/null && exit 1 + +# expect these to succeed +guile -q -c '(require-extension (srfi 1)) (exit (procedure? take-right))' +guile -q -c '(require-extension (srfi))' + +exit 0 diff --git a/test-suite/standalone/test-round.c b/test-suite/standalone/test-round.c new file mode 100644 index 000000000..c9175b230 --- /dev/null +++ b/test-suite/standalone/test-round.c @@ -0,0 +1,149 @@ +/* Copyright 2004,2006,2008-2009,2011,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <assert.h> +#include <math.h> +#include <stdio.h> + +#if HAVE_FENV_H +# if defined __GNUC__ && defined __GLIBC__ +/* In Glibc 2.17, <bits/fenv.h> defines `feraiseexcept' as an inline + without declaring it first, so ignore the warning. */ +# pragma GCC diagnostic push +# pragma GCC diagnostic ignored "-Wmissing-prototypes" +# endif +# include <fenv.h> +# if defined __GNUC__ && defined __GLIBC__ +# pragma GCC diagnostic pop +# endif +#elif defined HAVE_MACHINE_FPU_H +/* On Tru64 5.1b, the declaration of fesetround(3) is in <machine/fpu.h>. + On NetBSD, this header has to be included along with <sys/types.h>. */ +# ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +# endif +# include <machine/fpu.h> +#endif + +#include <libguile.h> + + +#define numberof(x) (sizeof (x) / sizeof ((x)[0])) + +static void +test_scm_c_round () +{ + /* FE constants are defined only where supported, in particular for + instance some ARM systems have been seen with only a couple of modes */ + static const int modes[] = { + 0, +#ifdef FE_TONEAREST + FE_TONEAREST, +#endif +#ifdef FE_UPWARD + FE_UPWARD, +#endif +#ifdef FE_DOWNWARD + FE_DOWNWARD, +#endif +#ifdef FE_TOWARDZERO + FE_TOWARDZERO, +#endif + }; + + double x, want; + int i; + + for (i = 0; i < numberof (modes); i++) + { + /* First iteration is the default rounding mode, ie. no call to + fesetround. Subsequent iterations are the FE modes from the + table. */ + if (i != 0) + { +#ifdef HAVE_FESETROUND + fesetround (modes[i]); +#endif + } + + assert (scm_c_round (0.0) == 0.0); + assert (scm_c_round (1.0) == 1.0); + assert (scm_c_round (-1.0) == -1.0); + + assert (scm_c_round (0.5) == 0.0); + assert (scm_c_round (1.5) == 2.0); + assert (scm_c_round (-1.5) == -2.0); + assert (scm_c_round (2.5) == 2.0); + assert (scm_c_round (-2.5) == -2.0); + assert (scm_c_round (3.5) == 4.0); + assert (scm_c_round (-3.5) == -4.0); + + /* 2^(DBL_MANT_DIG-1)-1+0.5 */ + x = ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5; + want = ldexp (1.0, DBL_MANT_DIG - 1); + assert (scm_c_round (x) == want); + + /* -(2^(DBL_MANT_DIG-1)-1+0.5) */ + x = - (ldexp (1.0, DBL_MANT_DIG - 1) - 1.0 + 0.5); + want = - ldexp (1.0, DBL_MANT_DIG - 1); + assert (scm_c_round (x) == want); + + /* 2^DBL_MANT_DIG-1 + In the past scm_c_round had incorrectly incremented this value, due + to the way that x+0.5 would round upwards (in the usual default + nearest-even mode on most systems). */ + x = ldexp (1.0, DBL_MANT_DIG) - 1.0; + assert (x == floor (x)); /* should be an integer already */ + assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */ + + /* -(2^DBL_MANT_DIG-1) */ + x = - (ldexp (1.0, DBL_MANT_DIG) - 1.0); + assert (x == floor (x)); /* should be an integer already */ + assert (scm_c_round (x) == x); /* scm_c_round should return it unchanged */ + + /* 2^64 */ + x = ldexp (1.0, 64); + assert (scm_c_round (x) == x); + + /* -2^64 + In the past scm_c_round had incorrectely gone to the next highest + representable value in FE_UPWARD, due to x+0.5 rounding. */ + x = - ldexp (1.0, 64); + assert (scm_c_round (x) == x); + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_round (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c new file mode 100644 index 000000000..cb6af7adc --- /dev/null +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -0,0 +1,232 @@ +/* Copyright 2013-2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <libguile.h> + +#include <assert.h> + +static SCM +test_unrecognized_keyword (void *data) +{ + SCM k_foo = scm_from_utf8_keyword ("foo"); + SCM k_bar = scm_from_utf8_keyword ("bar"); + SCM k_baz = scm_from_utf8_keyword ("baz"); + SCM arg_foo, arg_bar; + + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_foo, SCM_EOL, + k_baz, SCM_BOOL_T, + SCM_UNDEFINED), + SCM_ALLOW_NON_KEYWORD_ARGUMENTS, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (0); +} + +static SCM +unrecognized_keyword_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Unrecognized keyword"), + SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("baz")), + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + +static SCM +test_invalid_keyword (void *data) +{ + SCM k_foo = scm_from_utf8_keyword ("foo"); + SCM k_bar = scm_from_utf8_keyword ("bar"); + SCM arg_foo, arg_bar; + + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_foo, SCM_EOL, + SCM_INUM0, SCM_INUM1, + SCM_UNDEFINED), + SCM_ALLOW_OTHER_KEYS, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (0); +} + +static SCM +invalid_keyword_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Invalid keyword"), + SCM_EOL, scm_list_1 (SCM_INUM0), + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + +static SCM +test_missing_value (void *data) +{ + SCM k_foo = scm_from_utf8_keyword ("foo"); + SCM arg_foo; + + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_foo, + SCM_UNDEFINED), + SCM_ALLOW_OTHER_KEYS, + k_foo, &arg_foo, + SCM_UNDEFINED); + assert (0); +} + +static SCM +missing_value_error_handler (void *data, SCM key, SCM args) +{ + SCM expected_args = scm_list_n + (scm_from_utf8_string ("test"), + scm_from_utf8_string ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("foo")), + SCM_UNDEFINED); + + assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + assert (scm_is_true (scm_equal_p (args, expected_args))); + + return SCM_BOOL_T; +} + +static void +test_scm_c_bind_keyword_arguments () +{ + SCM k_foo = scm_from_utf8_keyword ("foo"); + SCM k_bar = scm_from_utf8_keyword ("bar"); + SCM k_baz = scm_from_utf8_keyword ("baz"); + SCM arg_foo, arg_bar; + + /* All kwargs provided. */ + arg_foo = SCM_INUM0; + arg_bar = SCM_INUM1; + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_bar, SCM_EOL, + k_foo, SCM_BOOL_T, + SCM_UNDEFINED), + 0, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (scm_is_eq (arg_foo, SCM_BOOL_T)); + assert (scm_is_eq (arg_bar, SCM_EOL)); + + /* Some kwargs provided. */ + arg_foo = SCM_INUM0; + arg_bar = SCM_INUM1; + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_bar, SCM_EOL, + SCM_UNDEFINED), + 0, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (scm_is_eq (arg_foo, SCM_INUM0)); + assert (scm_is_eq (arg_bar, SCM_EOL)); + + /* No kwargs provided. */ + arg_foo = SCM_INUM0; + arg_bar = SCM_INUM1; + scm_c_bind_keyword_arguments ("test", + SCM_EOL, + 0, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (scm_is_eq (arg_foo, SCM_INUM0)); + assert (scm_is_eq (arg_bar, SCM_INUM1)); + + /* Other kwargs provided, when allowed. */ + arg_foo = SCM_INUM0; + arg_bar = SCM_INUM1; + scm_c_bind_keyword_arguments ("test", + scm_list_n (k_foo, SCM_EOL, + k_baz, SCM_BOOL_T, + SCM_UNDEFINED), + SCM_ALLOW_OTHER_KEYS, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (scm_is_eq (arg_foo, SCM_EOL)); + assert (scm_is_eq (arg_bar, SCM_INUM1)); + + /* Other non-kwargs provided, when allowed. */ + arg_foo = SCM_INUM0; + arg_bar = SCM_INUM1; + scm_c_bind_keyword_arguments ("test", + scm_list_n (SCM_BOOL_F, + k_foo, SCM_EOL, + SCM_INUM0, + k_bar, SCM_BOOL_T, + SCM_INUM1, + SCM_UNDEFINED), + SCM_ALLOW_NON_KEYWORD_ARGUMENTS, + k_foo, &arg_foo, + k_bar, &arg_bar, + SCM_UNDEFINED); + assert (scm_is_eq (arg_foo, SCM_EOL)); + assert (scm_is_eq (arg_bar, SCM_BOOL_T)); + + /* Test unrecognized keyword error. */ + scm_internal_catch (SCM_BOOL_T, + test_unrecognized_keyword, NULL, + unrecognized_keyword_error_handler, NULL); + + /* Test invalid keyword error. */ + scm_internal_catch (SCM_BOOL_T, + test_invalid_keyword, NULL, + invalid_keyword_error_handler, NULL); + + /* Test missing value error. */ + scm_internal_catch (SCM_BOOL_T, + test_missing_value, NULL, + missing_value_error_handler, NULL); +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_bind_keyword_arguments (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c new file mode 100644 index 000000000..14a95a1d1 --- /dev/null +++ b/test-suite/standalone/test-scm-c-read.c @@ -0,0 +1,124 @@ +/* Copyright 2008,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Exercise `scm_c_read ()' and the port type API. Verify assumptions that + can be made by port type implementations. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <assert.h> +#include <string.h> +#include <libguile.h> + + + +/* Size of our port's internal buffer. */ +#define PORT_BUFFER_SIZE 1024 + +struct custom_port +{ + size_t pos; + size_t len; + char *buf; +}; + + +/* Return a new port of type PORT_TYPE. */ +static inline SCM +make_port (scm_t_port_type *port_type) +{ + struct custom_port *stream = scm_gc_typed_calloc (struct custom_port); + + stream->pos = 0; + stream->len = PORT_BUFFER_SIZE; + stream->buf = scm_gc_calloc (stream->len, "custom-port-buffer"); + + return scm_c_make_port (port_type, SCM_RDNG, (scm_t_bits) stream); +} + +static size_t +custom_port_read (SCM port, SCM dst, size_t start, size_t count) +{ + size_t to_copy = count; + struct custom_port *stream = (void *) SCM_STREAM (port); + + if (stream->pos + to_copy > stream->len) + to_copy = stream->len - stream->pos; + + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + stream->buf + stream->pos, to_copy); + stream->pos += to_copy; + + return to_copy; +} + +/* Return true (non-zero) if BUF contains only zeros. */ +static inline int +zeroed_buffer_p (const char *buf, size_t len) +{ + size_t i; + + for (i = 0; i < len; i++) + if (buf[i] != 0) + return 0; + + return 1; +} + +/* Run the test. */ +static void * +do_start (void *arg) +{ + SCM port; + scm_t_port_type *port_type; + char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)]; + size_t read, last_read; + + port_type = scm_make_port_type ("custom-input-port", custom_port_read, NULL); + port = make_port (port_type); + + read = 0; + do + { + last_read = scm_c_read (port, &buffer[read], 123); + assert (last_read <= 123); + assert (zeroed_buffer_p (&buffer[read], last_read)); + + read += last_read; + } + while (last_read > 0 && read < sizeof (buffer)); + + /* We shouldn't be able to read more than what's in PORT's buffer. */ + assert (read == PORT_BUFFER_SIZE); + + return NULL; +} + + +int +main (int argc, char *argv[]) +{ + scm_with_guile (do_start, NULL); + + return 0; +} diff --git a/test-suite/standalone/test-scm-spawn-thread.c b/test-suite/standalone/test-scm-spawn-thread.c new file mode 100644 index 000000000..620c9f8f1 --- /dev/null +++ b/test-suite/standalone/test-scm-spawn-thread.c @@ -0,0 +1,63 @@ +/* Copyright 2011-2012,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Test whether a thread created with `scm_spawn_thread' can be joined. + See <http://thread.gmane.org/gmane.lisp.guile.devel/11804> for the + original report. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <time.h> +#include <stdlib.h> + +static SCM +thread_main (void *data) +{ + return SCM_BOOL_T; +} + +static SCM +thread_handler (void *data, SCM key, SCM args) +{ + return SCM_BOOL_T; +} + +static void * +inner_main (void *data) +{ + SCM thread, timeout; + + thread = scm_spawn_thread (thread_main, 0, thread_handler, 0); + timeout = scm_from_unsigned_integer (time (NULL) + 10); + return SCM2PTR (scm_join_thread_timed (thread, timeout, SCM_BOOL_F)); +} + + +int +main (int argc, char **argv) +{ + SCM result; + + result = PTR2SCM (scm_with_guile (inner_main, 0)); + return scm_is_true (result) ? EXIT_SUCCESS : EXIT_FAILURE; +} diff --git a/test-suite/standalone/test-scm-take-locale-symbol.c b/test-suite/standalone/test-scm-take-locale-symbol.c new file mode 100644 index 000000000..55303fb01 --- /dev/null +++ b/test-suite/standalone/test-scm-take-locale-symbol.c @@ -0,0 +1,65 @@ +/* Copyright 2009,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned + symbol. See https://savannah.gnu.org/bugs/index.php?25865 . */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <stdlib.h> +#include <string.h> + + +static void * +do_test (void *result) +{ + SCM taken_sym, sym; + + taken_sym = scm_take_locale_symbol (strdup ("some random symbol")); + sym = scm_from_locale_symbol ("some random symbol"); + + if (scm_is_true (scm_symbol_p (sym)) + && scm_is_true (scm_symbol_p (taken_sym)) + + /* Relying solely on `scm_symbol_interned_p ()' is insufficient since + it doesn't reflect the actual state of the symbol hashtable, hence + the additional `scm_is_eq' test. */ + && scm_is_true (scm_symbol_interned_p (sym)) + && scm_is_true (scm_symbol_interned_p (taken_sym)) + && scm_is_eq (taken_sym, sym)) + * (int *) result = EXIT_SUCCESS; + else + * (int *) result = EXIT_FAILURE; + + return NULL; +} + +int +main (int argc, char *argv[]) +{ + int result; + + scm_with_guile (do_test, &result); + + return result; +} diff --git a/test-suite/standalone/test-scm-take-u8vector.c b/test-suite/standalone/test-scm-take-u8vector.c new file mode 100644 index 000000000..dc8bc11a1 --- /dev/null +++ b/test-suite/standalone/test-scm-take-u8vector.c @@ -0,0 +1,66 @@ +/* Copyright 2009,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the + provided storage. */ + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +#include <stdlib.h> + + +static void * +do_test (void *result) +{ +#define LEN 123 + SCM u8v; + uint8_t *data; + scm_t_array_handle handle; + + data = scm_malloc (LEN); + u8v = scm_take_u8vector (data, LEN); + + scm_array_get_handle (u8v, &handle); + + if (scm_array_handle_u8_writable_elements (&handle) == data + && scm_array_handle_u8_elements (&handle) == data) + * (int *) result = EXIT_SUCCESS; + else + * (int *) result = EXIT_FAILURE; + + scm_array_handle_release (&handle); + + return NULL; +#undef LEN +} + +int +main (int argc, char *argv[]) +{ + int result; + + scm_with_guile (do_test, &result); + + return result; +} diff --git a/test-suite/standalone/test-scm-to-latin1-string.c b/test-suite/standalone/test-scm-to-latin1-string.c new file mode 100644 index 000000000..d39789533 --- /dev/null +++ b/test-suite/standalone/test-scm-to-latin1-string.c @@ -0,0 +1,81 @@ +/* Copyright 2011,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdlib.h> +#include <string.h> + +#include <libguile.h> + +/* + This outputs: + + dhansen@localhorst ~/tmp $ ./a.out + foo,bar + bar + +*/ + +#define TEST(x) \ + if (!(x)) abort() + +static void +inner_main (void *data, int argc, char **argv) +{ + char *cstr; + + SCM string, tokens, tok; + + string = scm_from_latin1_string ("foo,bar"); + tokens = scm_string_split (string, SCM_MAKE_CHAR (',')); + + TEST (scm_is_pair (tokens)); + tok = scm_car (tokens); + TEST (scm_is_string (tok)); + cstr = scm_to_latin1_string (tok); + TEST (strcmp (cstr, "foo") == 0); + free (cstr); + tokens = scm_cdr (tokens); + + TEST (scm_is_pair (tokens)); + tok = scm_car (tokens); + TEST (scm_is_string (tok)); + cstr = scm_to_latin1_string (tok); + TEST (strcmp (cstr, "bar") == 0); + free (cstr); + tokens = scm_cdr (tokens); + + TEST (scm_is_null (tokens)); +} + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, NULL); + + return EXIT_SUCCESS; +} + +/* Local Variables: */ +/* compile-command: "gcc `pkg-config --cflags --libs guile-2.0` main.c" */ +/* End: */ diff --git a/test-suite/standalone/test-scm-values.c b/test-suite/standalone/test-scm-values.c new file mode 100644 index 000000000..70a53f16c --- /dev/null +++ b/test-suite/standalone/test-scm-values.c @@ -0,0 +1,72 @@ +/* Copyright 2012,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#undef NDEBUG + +#include <assert.h> +#include <libguile.h> +#include <stdlib.h> +#include <string.h> + +static void +test_scm_c_value_ref_on_multiple_values () +{ + SCM values = scm_values (scm_list_3 (scm_from_latin1_string ("foo"), + scm_from_latin1_string ("bar"), + scm_from_latin1_string ("baz"))); + + char *foo = scm_to_latin1_string (scm_c_value_ref (values, 0)); + char *bar = scm_to_latin1_string (scm_c_value_ref (values, 1)); + char *baz = scm_to_latin1_string (scm_c_value_ref (values, 2)); + + assert (strcmp (foo, "foo") == 0); + assert (strcmp (bar, "bar") == 0); + assert (strcmp (baz, "baz") == 0); + + free (foo); + free (bar); + free (baz); +} + +static void +test_scm_c_value_ref_on_a_single_value () +{ + SCM value = scm_from_latin1_string ("foo"); + char *foo = scm_to_latin1_string (scm_c_value_ref (value, 0)); + assert (strcmp (foo, "foo") == 0); + free (foo); +} + +static void +tests (void *data, int argc, char **argv) +{ + test_scm_c_value_ref_on_multiple_values (); + test_scm_c_value_ref_on_a_single_value (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-scm-with-guile.c b/test-suite/standalone/test-scm-with-guile.c new file mode 100644 index 000000000..332769114 --- /dev/null +++ b/test-suite/standalone/test-scm-with-guile.c @@ -0,0 +1,68 @@ +/* Copyright 2008,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + +/* Test whether `scm_with_guile ()' can be called several times from a given + thread, but from a different stack depth. Up to 1.8.5, `scm_with_guile + ()' would not update the thread's `base' field, which would then confuse + the GC. + + See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00037.html + for a detailed report. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <libguile.h> + +static void * +entry_point (void *arg) +{ + /* Invoke the GC. If `THREAD->base' is incorrect, then Guile will just + segfault somewhere in `scm_mark_locations ()'. */ + scm_gc (); + + return NULL; +} + +static void +go_deeper_into_the_stack (unsigned level) +{ + /* The assumption is that the compiler is not smart enough to optimize this + out. */ + if (level > 0) + go_deeper_into_the_stack (level - 1); + else + scm_with_guile (entry_point, NULL); +} + + +int +main (int argc, char *argv[]) +{ + /* Invoke `scm_with_guile ()' from someplace deep into the stack. */ + go_deeper_into_the_stack (100); + + /* Invoke it from much higher into the stack. This time, Guile is expected + to update the `base' field of the current thread. */ + scm_with_guile (entry_point, NULL); + + return 0; +} diff --git a/test-suite/standalone/test-smob-mark-race.c b/test-suite/standalone/test-smob-mark-race.c new file mode 100644 index 000000000..31aba8c30 --- /dev/null +++ b/test-suite/standalone/test-smob-mark-race.c @@ -0,0 +1,66 @@ +/* Copyright 2016 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +#include <config.h> +#endif + +#undef NDEBUG + +#include <libguile.h> +#include <assert.h> + +static SCM +mark_smob (SCM smob) +{ + assert (SCM_SMOB_DATA (smob) == 1); + return SCM_BOOL_F; +} + +static size_t +finalize_smob (SCM smob) +{ + assert (SCM_SMOB_DATA (smob) == 1); + SCM_SET_SMOB_DATA (smob, 0); + /* Allocate a bit in the hopes of triggering a new GC, making the + marker race with the finalizer. */ + scm_cons (SCM_BOOL_F, SCM_BOOL_F); + return 0; +} + +static void +tests (void *data, int argc, char **argv) +{ + scm_t_bits tc16; + int i; + + tc16 = scm_make_smob_type ("smob with finalizer", 0); + scm_set_smob_mark (tc16, mark_smob); + scm_set_smob_free (tc16, finalize_smob); + + for (i = 0; i < 1000 * 1000; i++) + scm_new_smob (tc16, 1); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-smob-mark.c b/test-suite/standalone/test-smob-mark.c new file mode 100644 index 000000000..d0bb5336a --- /dev/null +++ b/test-suite/standalone/test-smob-mark.c @@ -0,0 +1,136 @@ +/* Copyright 2013-2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +#include <config.h> +#endif + +#undef NDEBUG + +#include <assert.h> +#include <libguile.h> +#include <stdio.h> +#include <stdlib.h> + +#define SMOBS_COUNT (10000) + +struct x_tag +{ + SCM scm_value; + int c_value; +}; + +typedef struct x_tag x_t; + +unsigned int mark_call_count = 0; + +static scm_t_bits x_tag; +static SCM make_x (void); +static SCM mark_x (SCM x); +static int print_x (SCM x, SCM port, scm_print_state * pstate); +static size_t free_x (SCM x); +static void init_smob_type (void); +static void test_scm_smob_mark (void); + +static SCM +make_x () +{ + static int i = 0; + SCM s_x; + x_t *c_x; + + i++; + c_x = (x_t *) scm_gc_malloc (sizeof (x_t), "x"); + c_x->scm_value = scm_from_int (i); + c_x->c_value = i; + SCM_NEWSMOB (s_x, x_tag, c_x); + return s_x; +} + +static SCM +mark_x (SCM x) +{ + x_t *c_x; + c_x = (x_t *) SCM_SMOB_DATA (x); + scm_gc_mark (c_x->scm_value); + mark_call_count++; + return SCM_BOOL_F; +} + +static size_t +free_x (SCM x) +{ + x_t *c_x; + c_x = (x_t *) SCM_SMOB_DATA (x); + scm_gc_free (c_x, sizeof (x_t), "x"); + c_x = NULL; + return 0; +} + +static int +print_x (SCM x, SCM port, scm_print_state * pstate SCM_UNUSED) +{ + x_t *c_x = (x_t *) SCM_SMOB_DATA (x); + scm_puts ("#<x ", port); + if (c_x == (x_t *) NULL) + scm_puts ("(freed)", port); + else + scm_write (c_x->scm_value, port); + scm_puts (">", port); + + return 1; +} + +static void +test_scm_smob_mark () +{ + int i; + mark_call_count = 0; + for (i = 0; i < SMOBS_COUNT; i++) + make_x (); + scm_gc (); + if (mark_call_count < SMOBS_COUNT) + { + fprintf (stderr, "FAIL: SMOB mark function called for each SMOB\n"); + exit (EXIT_FAILURE); + } +} + +static void +init_smob_type () +{ + x_tag = scm_make_smob_type ("x", sizeof (x_t)); + scm_set_smob_free (x_tag, free_x); + scm_set_smob_print (x_tag, print_x); + scm_set_smob_mark (x_tag, mark_x); +} + +static void +tests (void *data, int argc, char **argv) +{ + init_smob_type (); + test_scm_smob_mark (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-srfi-4.c b/test-suite/standalone/test-srfi-4.c new file mode 100644 index 000000000..82897df27 --- /dev/null +++ b/test-suite/standalone/test-srfi-4.c @@ -0,0 +1,91 @@ +/* Copyright 2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +/* Make sure the assertions are tested. */ +#undef NDEBUG + +#include <libguile.h> + +#include <stdio.h> +#include <assert.h> + +static void +test_writable_elements () +{ + SCM elts = scm_list_4 (scm_from_int (1), scm_from_int (2), + scm_from_int (3), scm_from_int (4)); + + { + SCM v = scm_u32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + uint32_t *elts = scm_u32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1); + assert (elts[3] == 4); + scm_array_handle_release (&h); + } + + { + SCM v = scm_f32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_f32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[3] == 4.0); + scm_array_handle_release (&h); + } + + { + SCM v = scm_c32vector (elts); + size_t len; + ssize_t inc; + scm_t_array_handle h; + float *elts = scm_c32vector_writable_elements (v, &h, &len, &inc); + assert (len == 4); + assert (inc == 1); + assert (elts[0] == 1.0); + assert (elts[1] == 0.0); + assert (elts[6] == 4.0); + assert (elts[7] == 0.0); + scm_array_handle_release (&h); + } +} + +static void +tests (void *data, int argc, char **argv) +{ + test_writable_elements (); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} diff --git a/test-suite/standalone/test-stack-overflow b/test-suite/standalone/test-stack-overflow new file mode 100755 index 000000000..dd54249d8 --- /dev/null +++ b/test-suite/standalone/test-stack-overflow @@ -0,0 +1,60 @@ +#!/bin/sh +guild compile "$0" +exec guile -q -s "$0" "$@" +!# + +(unless (defined? 'setrlimit) + ;; Without an rlimit, this test can take down your system, as it + ;; consumes all of your memory in stack space. That doesn't seem like + ;; something we should run as part of an automated test suite. + (exit 0)) + +(when (string-ci= "darwin" (vector-ref (uname) 0)) + ;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding + ;; with the test would fill all available memory and probably end in a crash. + ;; See also test-out-of-memory. + (exit 77)) ; uresolved + +(when (string-ci= "GNU" (vector-ref (uname) 0)) + ;; setrlimits are not yet implemented on GNU/Hurd systems. Proceeding + ;; with the test would end in a crash. See + ;; <https://lists.gnu.org/archive/html/bug-hurd/2017-05/msg00013.html> + (exit 77)) ; unresolved + +(when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") + ;; attempting to use setrlimits for memory RLIMIT_AS will always + ;; produce an invalid argument error on Cygwin (tested on + ;; CYGWIN_NT-10.0 DLL v2.7.0). Proceeding with the test would fill + ;; all available memory and probably end in a crash. See also + ;; test-out-of-memory. + (exit 77)) ; unresolved + +;; 100 MB. +(define *limit* (* 100 1024 1024)) + +(call-with-values (lambda () (getrlimit 'as)) + (lambda (soft hard) + (unless (and soft (< soft *limit*)) + (setrlimit 'as (if hard (min *limit* hard) *limit*) hard)))) + +(define (test) + (catch 'stack-overflow + (lambda () + (let lp () + (lp) + (error "should not be reached"))) + (lambda _ + #t))) + +;; Run the test a few times. The stack will only be enlarged and +;; relocated on the first one. + +(test) +(test) +(test) +(test) +(test) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-system-cmds b/test-suite/standalone/test-system-cmds new file mode 100755 index 000000000..8c590835d --- /dev/null +++ b/test-suite/standalone/test-system-cmds @@ -0,0 +1,44 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +(define (test-system-cmd) + (if (not (boolean? (system))) + (begin + (simple-format + #t + "test-system-cmds: (system) did not return a boolean\n") + (exit 1))) + + ;; Note: Use double quotes since simple quotes are not supported by + ;; `cmd.exe' on Windows. + (let ((rs (status:exit-val (system "guile -c \"(exit 42)\"")))) + (if (not (= 42 rs)) + (begin + (simple-format + #t + "test-system-cmds: system exit status was ~S rather than 42\n" + rs) + (exit 1))))) + +(define (test-system*-cmd) + (let ((rs (status:exit-val (system* "guile" "-c" "(exit 42)")))) + (if (not (= 42 rs)) + (begin + (simple-format + #t + "test-system-cmds: system* exit status was ~S rather than 42\n" + rs) + (exit 1))))) + +(if (defined? 'system) + (test-system-cmd)) + +(if (defined? 'system*) + (test-system*-cmd)) + +(exit 0) + +;; Local Variables: +;; mode: scheme +;; End: diff --git a/test-suite/standalone/test-unwind.c b/test-suite/standalone/test-unwind.c new file mode 100644 index 000000000..fe10d2ddc --- /dev/null +++ b/test-suite/standalone/test-unwind.c @@ -0,0 +1,310 @@ +/* Copyright 2004-2005,2008-2010,2013,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <alloca.h> + +#include <libguile.h> +#include <stdlib.h> +#include <stdio.h> +#include <unistd.h> + +#ifdef HAVE_STRING_H +# include <string.h> +#endif + + +void set_flag (void *data); +void func1 (void); +void func2 (void); +void func3 (void); +void func4 (void); +void check_flag1 (const char *msg, void (*func)(void), int val); +SCM check_flag1_body (void *data); +SCM return_tag (void *data, SCM tag, SCM args); +void check_cont (int rewindable); +SCM check_cont_body (void *data); +void close_port (SCM port); +void delete_file (void *data); +void check_ports (void); +void check_fluid (void); + +int flag1, flag2, flag3; + +void +set_flag (void *data) +{ + int *f = (int *)data; + *f = 1; +} + +/* FUNC1 should leave flag1 zero. + */ + +void +func1 () +{ + scm_dynwind_begin (0); + flag1 = 0; + scm_dynwind_unwind_handler (set_flag, &flag1, 0); + scm_dynwind_end (); +} + +/* FUNC2 should set flag1. + */ + +void +func2 () +{ + scm_dynwind_begin (0); + flag1 = 0; + scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY); + scm_dynwind_end (); +} + +/* FUNC3 should set flag1. + */ + +void +func3 () +{ + scm_dynwind_begin (0); + flag1 = 0; + scm_dynwind_unwind_handler (set_flag, &flag1, 0); + scm_misc_error ("func3", "gratuitous error", SCM_EOL); + scm_dynwind_end (); +} + +/* FUNC4 should set flag1. + */ + +void +func4 () +{ + scm_dynwind_begin (0); + flag1 = 0; + scm_dynwind_unwind_handler (set_flag, &flag1, SCM_F_WIND_EXPLICITLY); + scm_misc_error ("func4", "gratuitous error", SCM_EOL); + scm_dynwind_end (); +} + +SCM +check_flag1_body (void *data) +{ + void (*f)(void) = (void (*)(void))data; + f (); + return SCM_UNSPECIFIED; +} + +SCM +return_tag (void *data, SCM tag, SCM args) +{ + return tag; +} + +void +check_flag1 (const char *tag, void (*func)(void), int val) +{ + scm_internal_catch (SCM_BOOL_T, + check_flag1_body, func, + return_tag, NULL); + if (flag1 != val) + { + printf ("%s failed\n", tag); + exit (EXIT_FAILURE); + } +} + +SCM +check_cont_body (void *data) +{ + scm_t_dynwind_flags flags = (data? SCM_F_DYNWIND_REWINDABLE : 0); + SCM val; + + scm_dynwind_begin (flags); + val = scm_c_eval_string ("(call/cc (lambda (k) k))"); + scm_dynwind_end (); + return val; +} + +void +check_cont (int rewindable) +{ + SCM res; + + res = scm_internal_catch (SCM_BOOL_T, + check_cont_body, (void *)(long)rewindable, + return_tag, NULL); + + /* RES is now either the created continuation, the value passed to + the continuation, or a catch-tag, such as 'misc-error. + */ + + if (scm_is_true (scm_procedure_p (res))) + { + /* a continuation, invoke it */ + scm_call_1 (res, SCM_BOOL_F); + } + else if (scm_is_false (res)) + { + /* the result of invoking the continuation, dynwind must be + rewindable */ + if (rewindable) + return; + printf ("continuation not blocked\n"); + exit (EXIT_FAILURE); + } + else + { + /* the catch tag, dynwind must not have been rewindable. */ + if (!rewindable) + return; + printf ("continuation didn't work\n"); + exit (EXIT_FAILURE); + } +} + +void +close_port (SCM port) +{ + scm_close_port (port); +} + +void +delete_file (void *data) +{ + unlink ((char *)data); +} + +void +check_ports () +{ +#define FILENAME_TEMPLATE "/check-ports.XXXXXX" + char *filename; + const char *tmpdir = getenv ("TMPDIR"); +#ifdef __MINGW32__ + extern int mkstemp (char *); + + /* On Windows neither $TMPDIR nor /tmp can be relied on. */ + if (tmpdir == NULL) + tmpdir = getenv ("TEMP"); + if (tmpdir == NULL) + tmpdir = getenv ("TMP"); + if (tmpdir == NULL) + tmpdir = "/"; +#else + if (tmpdir == NULL) + tmpdir = "/tmp"; +#endif + + filename = alloca (strlen (tmpdir) + sizeof (FILENAME_TEMPLATE) + 1); + strcpy (filename, tmpdir); + strcat (filename, FILENAME_TEMPLATE); + + /* Sanity check: Make sure that `filename' is actually writeable. + We used to use mktemp(3), but that is now considered a security risk. */ + if (0 > mkstemp (filename)) + exit (EXIT_FAILURE); + + scm_dynwind_begin (0); + { + SCM port = scm_open_file (scm_from_locale_string (filename), + scm_from_locale_string ("w")); + scm_dynwind_unwind_handler_with_scm (close_port, port, + SCM_F_WIND_EXPLICITLY); + + scm_dynwind_current_output_port (port); + scm_write (scm_version (), SCM_UNDEFINED); + } + scm_dynwind_end (); + + scm_dynwind_begin (0); + { + SCM port = scm_open_file (scm_from_locale_string (filename), + scm_from_locale_string ("r")); + SCM res; + scm_dynwind_unwind_handler_with_scm (close_port, port, + SCM_F_WIND_EXPLICITLY); + scm_dynwind_unwind_handler (delete_file, filename, SCM_F_WIND_EXPLICITLY); + + scm_dynwind_current_input_port (port); + res = scm_read (SCM_UNDEFINED); + if (scm_is_false (scm_equal_p (res, scm_version ()))) + { + printf ("ports didn't work\n"); + exit (EXIT_FAILURE); + } + } + scm_dynwind_end (); +#undef FILENAME_TEMPLATE +} + +void +check_fluid () +{ + SCM f = scm_make_fluid (); + SCM x; + + scm_fluid_set_x (f, scm_from_int (12)); + + scm_dynwind_begin (0); + scm_dynwind_fluid (f, scm_from_int (13)); + x = scm_fluid_ref (f); + scm_dynwind_end (); + + if (!scm_is_eq (x, scm_from_int (13))) + { + printf ("setting fluid didn't work\n"); + exit (EXIT_FAILURE); + } + + if (!scm_is_eq (scm_fluid_ref (f), scm_from_int (12))) + { + printf ("resetting fluid didn't work\n"); + exit (EXIT_FAILURE); + } +} + +static void +inner_main (void *data, int argc, char **argv) +{ + check_flag1 ("func1", func1, 0); + check_flag1 ("func2", func2, 1); + check_flag1 ("func3", func3, 1); + check_flag1 ("func4", func4, 1); + + check_cont (0); + check_cont (1); + + check_ports (); + + check_fluid (); + + exit (EXIT_SUCCESS); +} + +int +main (int argc, char **argv) +{ + scm_boot_guile (argc, argv, inner_main, 0); + return 0; +} diff --git a/test-suite/standalone/test-use-srfi.in b/test-suite/standalone/test-use-srfi.in new file mode 100755 index 000000000..ab9d5cd5e --- /dev/null +++ b/test-suite/standalone/test-use-srfi.in @@ -0,0 +1,68 @@ +#!/bin/sh + +# Copyright (C) 2006 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 + + +# Test that two srfi numbers on the command line work. +# +guile -q --use-srfi=1,10 >/dev/null <<EOF +(if (and (defined? 'partition) + (defined? 'define-reader-ctor)) + (exit 0) ;; good + (exit 1)) ;; bad +EOF +if test $? = 0; then :; else + echo "guile --use-srfi=1,10 fails to run" + exit 1 +fi + + +# Test that running "guile --use-srfi=1" leaves the interactive REPL with +# the srfi-1 version of iota. +# +# In guile 1.8.1 and earlier, and 1.6.8 and earlier, these failed because in +# `top-repl' the core bindings got ahead of anything --use-srfi gave. +# + +guile -q --use-srfi=1 >/dev/null <<EOF +(catch #t + (lambda () + (iota 2 3 4)) + (lambda args + (exit 1))) ;; bad +(exit 0) ;; good +EOF +if test $? = 0; then :; else + echo "guile --use-srfi=1 doesn't give SRFI-1 iota" + exit 1 +fi + + +# Similar test on srfi-17 car, which differs in being a #:replacement. This +# exercises duplicates handling in `top-repl' versus `use-srfis' (in +# boot-9.scm). +# +guile -q --use-srfi=17 >/dev/null <<EOF +(if (procedure-with-setter? car) + (exit 0) ;; good + (exit 1)) ;; bad +EOF +if test $? = 0; then :; else + echo "guile --use-srfi=17 doesn't give SRFI-17 car" + exit 1 +fi diff --git a/test-suite/standalone/test-with-guile-module.c b/test-suite/standalone/test-with-guile-module.c new file mode 100644 index 000000000..36d1f287a --- /dev/null +++ b/test-suite/standalone/test-with-guile-module.c @@ -0,0 +1,83 @@ +/* Copyright 2008,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <pthread.h> +#include <libguile.h> + +void *thread_inner_main (void *unused); +void *thread_main (void *unused); +void *do_join (void *data); +void *inner_main (void *unused); + +void * +thread_inner_main (void *unused) +{ + int argc = 3; + char *argv[] = { + "guile", + "-c", + "(or (current-module) (exit -1))", + 0 + }; + + scm_shell (argc, argv); + + return NULL; /* dummy */ +} + +void * +thread_main (void *unused) +{ + scm_with_guile (&thread_inner_main, NULL); + + return NULL; /* dummy */ +} + +void * +do_join (void *data) +{ + pthread_t *thread = (pthread_t *) data; + + pthread_join (*thread, NULL); + + return NULL; /* dummy */ +} + +void * +inner_main (void *unused) +{ + pthread_t thread; + + pthread_create (&thread, NULL, &thread_main, NULL); + scm_without_guile (do_join, &thread); + + return NULL; /* dummy */ +} + +int +main (int argc, char **argv) +{ + scm_with_guile (&inner_main, NULL); + + return 0; +} |