summaryrefslogtreecommitdiff
path: root/test-suite/standalone
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/standalone')
-rw-r--r--test-suite/standalone/.gitignore15
-rw-r--r--test-suite/standalone/Makefile.am301
-rw-r--r--test-suite/standalone/README29
-rwxr-xr-xtest-suite/standalone/test-asmobs118
-rw-r--r--test-suite/standalone/test-asmobs-lib.c210
-rwxr-xr-xtest-suite/standalone/test-bad-identifiers77
-rwxr-xr-xtest-suite/standalone/test-command-line-encoding24
-rwxr-xr-xtest-suite/standalone/test-command-line-encoding220
-rw-r--r--test-suite/standalone/test-conversion.c1205
-rwxr-xr-xtest-suite/standalone/test-extensions16
-rw-r--r--test-suite/standalone/test-extensions-lib.c45
-rw-r--r--test-suite/standalone/test-fast-slot-ref.in40
-rwxr-xr-xtest-suite/standalone/test-ffi294
-rw-r--r--test-suite/standalone/test-ffi-lib.c249
-rw-r--r--test-suite/standalone/test-foreign-object-c.c116
-rwxr-xr-xtest-suite/standalone/test-foreign-object-scm129
-rwxr-xr-xtest-suite/standalone/test-guild-compile47
-rwxr-xr-xtest-suite/standalone/test-guile-snarf38
-rwxr-xr-xtest-suite/standalone/test-import-order31
-rw-r--r--test-suite/standalone/test-import-order-a.scm4
-rw-r--r--test-suite/standalone/test-import-order-b.scm4
-rw-r--r--test-suite/standalone/test-import-order-c.scm4
-rw-r--r--test-suite/standalone/test-import-order-d.scm4
-rwxr-xr-xtest-suite/standalone/test-language27
-rw-r--r--test-suite/standalone/test-language.el11
-rw-r--r--test-suite/standalone/test-language.js12
-rw-r--r--test-suite/standalone/test-list.c66
-rw-r--r--test-suite/standalone/test-loose-ends.c110
-rwxr-xr-xtest-suite/standalone/test-mb-regexp39
-rw-r--r--test-suite/standalone/test-num2integral.c156
-rwxr-xr-xtest-suite/standalone/test-out-of-memory83
-rw-r--r--test-suite/standalone/test-pthread-create-secondary.c91
-rw-r--r--test-suite/standalone/test-pthread-create.c70
-rwxr-xr-xtest-suite/standalone/test-require-extension18
-rw-r--r--test-suite/standalone/test-round.c149
-rw-r--r--test-suite/standalone/test-scm-c-bind-keyword-arguments.c232
-rw-r--r--test-suite/standalone/test-scm-c-read.c124
-rw-r--r--test-suite/standalone/test-scm-spawn-thread.c63
-rw-r--r--test-suite/standalone/test-scm-take-locale-symbol.c65
-rw-r--r--test-suite/standalone/test-scm-take-u8vector.c66
-rw-r--r--test-suite/standalone/test-scm-to-latin1-string.c81
-rw-r--r--test-suite/standalone/test-scm-values.c72
-rw-r--r--test-suite/standalone/test-scm-with-guile.c68
-rw-r--r--test-suite/standalone/test-smob-mark-race.c66
-rw-r--r--test-suite/standalone/test-smob-mark.c136
-rw-r--r--test-suite/standalone/test-srfi-4.c91
-rwxr-xr-xtest-suite/standalone/test-stack-overflow60
-rwxr-xr-xtest-suite/standalone/test-system-cmds44
-rw-r--r--test-suite/standalone/test-unwind.c310
-rwxr-xr-xtest-suite/standalone/test-use-srfi.in68
-rw-r--r--test-suite/standalone/test-with-guile-module.c83
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;
+}