summaryrefslogtreecommitdiffstats
path: root/tests/gpgscm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/gpgscm')
-rw-r--r--tests/gpgscm/LICENSE.TinySCHEME31
-rw-r--r--tests/gpgscm/Makefile.am64
-rw-r--r--tests/gpgscm/Makefile.in882
-rw-r--r--tests/gpgscm/Manual.txt444
-rw-r--r--tests/gpgscm/ffi-private.h148
-rw-r--r--tests/gpgscm/ffi.c1470
-rw-r--r--tests/gpgscm/ffi.h30
-rw-r--r--tests/gpgscm/ffi.scm51
-rw-r--r--tests/gpgscm/gnupg.scm49
-rw-r--r--tests/gpgscm/init.scm823
-rw-r--r--tests/gpgscm/lib.scm307
-rw-r--r--tests/gpgscm/main.c362
-rw-r--r--tests/gpgscm/makefile.scm76
-rw-r--r--tests/gpgscm/opdefines.h205
-rw-r--r--tests/gpgscm/private.h26
-rw-r--r--tests/gpgscm/repl.scm69
-rw-r--r--tests/gpgscm/scheme-config.h32
-rw-r--r--tests/gpgscm/scheme-private.h274
-rw-r--r--tests/gpgscm/scheme.c6043
-rw-r--r--tests/gpgscm/scheme.h290
-rw-r--r--tests/gpgscm/small-integers.h847
-rw-r--r--tests/gpgscm/t-child.c74
-rw-r--r--tests/gpgscm/t-child.scm118
-rw-r--r--tests/gpgscm/tests.scm886
-rw-r--r--tests/gpgscm/time.scm42
-rw-r--r--tests/gpgscm/xml.scm142
26 files changed, 13785 insertions, 0 deletions
diff --git a/tests/gpgscm/LICENSE.TinySCHEME b/tests/gpgscm/LICENSE.TinySCHEME
new file mode 100644
index 0000000..23a7e85
--- /dev/null
+++ b/tests/gpgscm/LICENSE.TinySCHEME
@@ -0,0 +1,31 @@
+ LICENSE TERMS
+
+Copyright (c) 2000, Dimitrios Souflis
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+Neither the name of Dimitrios Souflis nor the names of the
+contributors may be used to endorse or promote products derived from
+this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/tests/gpgscm/Makefile.am b/tests/gpgscm/Makefile.am
new file mode 100644
index 0000000..44d7b3f
--- /dev/null
+++ b/tests/gpgscm/Makefile.am
@@ -0,0 +1,64 @@
+# TinyScheme-based test driver.
+#
+# Copyright (C) 2016 g10 Code GmbH
+#
+# This file is part of GnuPG.
+#
+# GnuPG is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# GnuPG 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, see <https://www.gnu.org/licenses/>.
+
+EXTRA_DIST = \
+ LICENSE.TinySCHEME \
+ Manual.txt \
+ ffi.scm \
+ init.scm \
+ lib.scm \
+ makefile.scm \
+ repl.scm \
+ t-child.scm \
+ xml.scm \
+ tests.scm \
+ gnupg.scm \
+ time.scm
+
+AM_CPPFLAGS = -I$(top_srcdir)/common
+include $(top_srcdir)/am/cmacros.am
+
+AM_CFLAGS =
+
+CLEANFILES =
+
+bin_PROGRAMS = gpgscm
+noinst_PROGRAMS = t-child
+
+common_libs = ../$(libcommon)
+commonpth_libs = ../$(libcommonpth)
+
+gpgscm_CFLAGS = -imacros scheme-config.h \
+ $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS)
+gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \
+ scheme-config.h scheme.c scheme.h scheme-private.h \
+ opdefines.h small-integers.h
+gpgscm_LDADD = $(LDADD) $(common_libs) \
+ $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \
+ $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS)
+
+t_child_SOURCES = t-child.c
+
+# Make sure that all libs are build before we use them. This is
+# important for things like make -j2.
+$(PROGRAMS): $(common_libs)
+
+check-local: gpgscm$(EXEEXT) t-child$(EXEEXT)
+ EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \
+ ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm
diff --git a/tests/gpgscm/Makefile.in b/tests/gpgscm/Makefile.in
new file mode 100644
index 0000000..503903a
--- /dev/null
+++ b/tests/gpgscm/Makefile.in
@@ -0,0 +1,882 @@
+# Makefile.in generated by automake 1.16.3 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994-2020 Free Software Foundation, Inc.
+
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+# TinyScheme-based test driver.
+#
+# Copyright (C) 2016 g10 Code GmbH
+#
+# This file is part of GnuPG.
+#
+# GnuPG is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# GnuPG 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, see <https://www.gnu.org/licenses/>.
+
+# cmacros.am - C macro definitions
+# Copyright (C) 2004 Free Software Foundation, Inc.
+#
+# This file is part of GnuPG.
+#
+# GnuPG is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# GnuPG 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 General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, see <https://www.gnu.org/licenses/>.
+
+VPATH = @srcdir@
+am__is_gnu_make = { \
+ if test -z '$(MAKELEVEL)'; then \
+ false; \
+ elif test -n '$(MAKE_HOST)'; then \
+ true; \
+ elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \
+ true; \
+ else \
+ false; \
+ fi; \
+}
+am__make_running_with_option = \
+ case $${target_option-} in \
+ ?) ;; \
+ *) echo "am__make_running_with_option: internal error: invalid" \
+ "target option '$${target_option-}' specified" >&2; \
+ exit 1;; \
+ esac; \
+ has_opt=no; \
+ sane_makeflags=$$MAKEFLAGS; \
+ if $(am__is_gnu_make); then \
+ sane_makeflags=$$MFLAGS; \
+ else \
+ case $$MAKEFLAGS in \
+ *\\[\ \ ]*) \
+ bs=\\; \
+ sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \
+ | sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \
+ esac; \
+ fi; \
+ skip_next=no; \
+ strip_trailopt () \
+ { \
+ flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \
+ }; \
+ for flg in $$sane_makeflags; do \
+ test $$skip_next = yes && { skip_next=no; continue; }; \
+ case $$flg in \
+ *=*|--*) continue;; \
+ -*I) strip_trailopt 'I'; skip_next=yes;; \
+ -*I?*) strip_trailopt 'I';; \
+ -*O) strip_trailopt 'O'; skip_next=yes;; \
+ -*O?*) strip_trailopt 'O';; \
+ -*l) strip_trailopt 'l'; skip_next=yes;; \
+ -*l?*) strip_trailopt 'l';; \
+ -[dEDm]) skip_next=yes;; \
+ -[JT]) skip_next=yes;; \
+ esac; \
+ case $$flg in \
+ *$$target_option*) has_opt=yes; break;; \
+ esac; \
+ done; \
+ test $$has_opt = yes
+am__make_dryrun = (target_option=n; $(am__make_running_with_option))
+am__make_keepgoing = (target_option=k; $(am__make_running_with_option))
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+@HAVE_DOSISH_SYSTEM_FALSE@am__append_1 = -DGNUPG_BINDIR="\"$(bindir)\"" \
+@HAVE_DOSISH_SYSTEM_FALSE@ -DGNUPG_LIBEXECDIR="\"$(libexecdir)\"" \
+@HAVE_DOSISH_SYSTEM_FALSE@ -DGNUPG_LIBDIR="\"$(libdir)/@PACKAGE@\"" \
+@HAVE_DOSISH_SYSTEM_FALSE@ -DGNUPG_DATADIR="\"$(datadir)/@PACKAGE@\"" \
+@HAVE_DOSISH_SYSTEM_FALSE@ -DGNUPG_SYSCONFDIR="\"$(sysconfdir)/@PACKAGE@\"" \
+@HAVE_DOSISH_SYSTEM_FALSE@ -DGNUPG_LOCALSTATEDIR="\"$(localstatedir)\""
+
+
+# If a specific protect tool program has been defined, pass its name
+# to cc. Note that these macros should not be used directly but via
+# the gnupg_module_name function.
+@GNUPG_AGENT_PGM_TRUE@am__append_2 = -DGNUPG_DEFAULT_AGENT="\"@GNUPG_AGENT_PGM@\""
+@GNUPG_PINENTRY_PGM_TRUE@am__append_3 = -DGNUPG_DEFAULT_PINENTRY="\"@GNUPG_PINENTRY_PGM@\""
+@GNUPG_SCDAEMON_PGM_TRUE@am__append_4 = -DGNUPG_DEFAULT_SCDAEMON="\"@GNUPG_SCDAEMON_PGM@\""
+@GNUPG_DIRMNGR_PGM_TRUE@am__append_5 = -DGNUPG_DEFAULT_DIRMNGR="\"@GNUPG_DIRMNGR_PGM@\""
+@GNUPG_PROTECT_TOOL_PGM_TRUE@am__append_6 = -DGNUPG_DEFAULT_PROTECT_TOOL="\"@GNUPG_PROTECT_TOOL_PGM@\""
+@GNUPG_DIRMNGR_LDAP_PGM_TRUE@am__append_7 = -DGNUPG_DEFAULT_DIRMNGR_LDAP="\"@GNUPG_DIRMNGR_LDAP_PGM@\""
+bin_PROGRAMS = gpgscm$(EXEEXT)
+noinst_PROGRAMS = t-child$(EXEEXT)
+subdir = tests/gpgscm
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/m4/autobuild.m4 \
+ $(top_srcdir)/m4/codeset.m4 $(top_srcdir)/m4/gettext.m4 \
+ $(top_srcdir)/m4/gpg-error.m4 $(top_srcdir)/m4/iconv.m4 \
+ $(top_srcdir)/m4/isc-posix.m4 $(top_srcdir)/m4/ksba.m4 \
+ $(top_srcdir)/m4/lcmessage.m4 $(top_srcdir)/m4/ldap.m4 \
+ $(top_srcdir)/m4/lib-ld.m4 $(top_srcdir)/m4/lib-link.m4 \
+ $(top_srcdir)/m4/lib-prefix.m4 $(top_srcdir)/m4/libassuan.m4 \
+ $(top_srcdir)/m4/libgcrypt.m4 $(top_srcdir)/m4/nls.m4 \
+ $(top_srcdir)/m4/npth.m4 $(top_srcdir)/m4/ntbtls.m4 \
+ $(top_srcdir)/m4/pkg.m4 $(top_srcdir)/m4/po.m4 \
+ $(top_srcdir)/m4/progtest.m4 $(top_srcdir)/m4/readline.m4 \
+ $(top_srcdir)/m4/socklen.m4 $(top_srcdir)/m4/sys_socket_h.m4 \
+ $(top_srcdir)/m4/tar-ustar.m4 $(top_srcdir)/acinclude.m4 \
+ $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON)
+mkinstalldirs = $(SHELL) $(top_srcdir)/build-aux/mkinstalldirs
+CONFIG_HEADER = $(top_builddir)/config.h
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+am__installdirs = "$(DESTDIR)$(bindir)"
+PROGRAMS = $(bin_PROGRAMS) $(noinst_PROGRAMS)
+am_gpgscm_OBJECTS = gpgscm-main.$(OBJEXT) gpgscm-ffi.$(OBJEXT) \
+ gpgscm-scheme.$(OBJEXT)
+gpgscm_OBJECTS = $(am_gpgscm_OBJECTS)
+am__DEPENDENCIES_1 =
+gpgscm_DEPENDENCIES = $(common_libs) $(am__DEPENDENCIES_1) \
+ $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
+ $(am__DEPENDENCIES_1) $(am__DEPENDENCIES_1) \
+ $(am__DEPENDENCIES_1)
+gpgscm_LINK = $(CCLD) $(gpgscm_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) \
+ $(LDFLAGS) -o $@
+am_t_child_OBJECTS = t-child.$(OBJEXT)
+t_child_OBJECTS = $(am_t_child_OBJECTS)
+t_child_LDADD = $(LDADD)
+AM_V_P = $(am__v_P_@AM_V@)
+am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
+am__v_P_0 = false
+am__v_P_1 = :
+AM_V_GEN = $(am__v_GEN_@AM_V@)
+am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
+am__v_GEN_0 = @echo " GEN " $@;
+am__v_GEN_1 =
+AM_V_at = $(am__v_at_@AM_V@)
+am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
+am__v_at_0 = @
+am__v_at_1 =
+DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir)
+depcomp = $(SHELL) $(top_srcdir)/build-aux/depcomp
+am__maybe_remake_depfiles = depfiles
+am__depfiles_remade = ./$(DEPDIR)/gpgscm-ffi.Po \
+ ./$(DEPDIR)/gpgscm-main.Po ./$(DEPDIR)/gpgscm-scheme.Po \
+ ./$(DEPDIR)/t-child.Po
+am__mv = mv -f
+AM_V_lt = $(am__v_lt_@AM_V@)
+am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
+am__v_lt_0 = --silent
+am__v_lt_1 =
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+AM_V_CC = $(am__v_CC_@AM_V@)
+am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@)
+am__v_CC_0 = @echo " CC " $@;
+am__v_CC_1 =
+CCLD = $(CC)
+LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@
+AM_V_CCLD = $(am__v_CCLD_@AM_V@)
+am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@)
+am__v_CCLD_0 = @echo " CCLD " $@;
+am__v_CCLD_1 =
+SOURCES = $(gpgscm_SOURCES) $(t_child_SOURCES)
+DIST_SOURCES = $(gpgscm_SOURCES) $(t_child_SOURCES)
+am__can_run_installinfo = \
+ case $$AM_UPDATE_INFO_DIR in \
+ n|no|NO) false;; \
+ *) (install-info --version) >/dev/null 2>&1;; \
+ esac
+am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP)
+# Read a list of newline-separated strings from the standard input,
+# and print each of them once, without duplicates. Input order is
+# *not* preserved.
+am__uniquify_input = $(AWK) '\
+ BEGIN { nonempty = 0; } \
+ { items[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in items) print i; }; } \
+'
+# Make sure the list of sources is unique. This is necessary because,
+# e.g., the same source file might be shared among _SOURCES variables
+# for different programs/libraries.
+am__define_uniq_tagged_files = \
+ list='$(am__tagged_files)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | $(am__uniquify_input)`
+ETAGS = etags
+CTAGS = ctags
+am__DIST_COMMON = $(srcdir)/Makefile.in $(top_srcdir)/am/cmacros.am \
+ $(top_srcdir)/build-aux/depcomp \
+ $(top_srcdir)/build-aux/mkinstalldirs
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+AWK_HEX_NUMBER_OPTION = @AWK_HEX_NUMBER_OPTION@
+BUILD_FILEVERSION = @BUILD_FILEVERSION@
+BUILD_HOSTNAME = @BUILD_HOSTNAME@
+BUILD_INCLUDED_LIBINTL = @BUILD_INCLUDED_LIBINTL@
+BUILD_REVISION = @BUILD_REVISION@
+BUILD_TIMESTAMP = @BUILD_TIMESTAMP@
+BUILD_VERSION = @BUILD_VERSION@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CC_FOR_BUILD = @CC_FOR_BUILD@
+CFLAGS = @CFLAGS@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DL_LIBS = @DL_LIBS@
+DNSLIBS = @DNSLIBS@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+ENCFS = @ENCFS@
+EXEEXT = @EXEEXT@
+FUSERMOUNT = @FUSERMOUNT@
+GETTEXT_MACRO_VERSION = @GETTEXT_MACRO_VERSION@
+GMSGFMT = @GMSGFMT@
+GMSGFMT_015 = @GMSGFMT_015@
+GNUPG_AGENT_PGM = @GNUPG_AGENT_PGM@
+GNUPG_DIRMNGR_LDAP_PGM = @GNUPG_DIRMNGR_LDAP_PGM@
+GNUPG_DIRMNGR_PGM = @GNUPG_DIRMNGR_PGM@
+GNUPG_PINENTRY_PGM = @GNUPG_PINENTRY_PGM@
+GNUPG_PROTECT_TOOL_PGM = @GNUPG_PROTECT_TOOL_PGM@
+GNUPG_SCDAEMON_PGM = @GNUPG_SCDAEMON_PGM@
+GPGKEYS_LDAP = @GPGKEYS_LDAP@
+GPGRT_CONFIG = @GPGRT_CONFIG@
+GPG_ERROR_CFLAGS = @GPG_ERROR_CFLAGS@
+GPG_ERROR_CONFIG = @GPG_ERROR_CONFIG@
+GPG_ERROR_LIBS = @GPG_ERROR_LIBS@
+GPG_ERROR_MT_CFLAGS = @GPG_ERROR_MT_CFLAGS@
+GPG_ERROR_MT_LIBS = @GPG_ERROR_MT_LIBS@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+INTLLIBS = @INTLLIBS@
+INTL_MACOSX_LIBS = @INTL_MACOSX_LIBS@
+KSBA_CFLAGS = @KSBA_CFLAGS@
+KSBA_CONFIG = @KSBA_CONFIG@
+KSBA_LIBS = @KSBA_LIBS@
+LBER_LIBS = @LBER_LIBS@
+LDAPLIBS = @LDAPLIBS@
+LDAP_CPPFLAGS = @LDAP_CPPFLAGS@
+LDFLAGS = @LDFLAGS@
+LIBASSUAN_CFLAGS = @LIBASSUAN_CFLAGS@
+LIBASSUAN_CONFIG = @LIBASSUAN_CONFIG@
+LIBASSUAN_LIBS = @LIBASSUAN_LIBS@
+LIBGCRYPT_CFLAGS = @LIBGCRYPT_CFLAGS@
+LIBGCRYPT_CONFIG = @LIBGCRYPT_CONFIG@
+LIBGCRYPT_LIBS = @LIBGCRYPT_LIBS@
+LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@
+LIBGNUTLS_LIBS = @LIBGNUTLS_LIBS@
+LIBICONV = @LIBICONV@
+LIBINTL = @LIBINTL@
+LIBOBJS = @LIBOBJS@
+LIBREADLINE = @LIBREADLINE@
+LIBS = @LIBS@
+LIBUSB_CPPFLAGS = @LIBUSB_CPPFLAGS@
+LIBUSB_LIBS = @LIBUSB_LIBS@
+LIBUTIL_LIBS = @LIBUTIL_LIBS@
+LN_S = @LN_S@
+LTLIBICONV = @LTLIBICONV@
+LTLIBINTL = @LTLIBINTL@
+LTLIBOBJS = @LTLIBOBJS@
+MAINT = @MAINT@
+MAKEINFO = @MAKEINFO@
+MKDIR_P = @MKDIR_P@
+MSGFMT = @MSGFMT@
+MSGFMT_015 = @MSGFMT_015@
+MSGMERGE = @MSGMERGE@
+NETLIBS = @NETLIBS@
+NPTH_CFLAGS = @NPTH_CFLAGS@
+NPTH_CONFIG = @NPTH_CONFIG@
+NPTH_LIBS = @NPTH_LIBS@
+NTBTLS_CFLAGS = @NTBTLS_CFLAGS@
+NTBTLS_CONFIG = @NTBTLS_CONFIG@
+NTBTLS_LIBS = @NTBTLS_LIBS@
+OBJEXT = @OBJEXT@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_GT = @PACKAGE_GT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+PERL = @PERL@
+PKG_CONFIG = @PKG_CONFIG@
+PKG_CONFIG_LIBDIR = @PKG_CONFIG_LIBDIR@
+PKG_CONFIG_PATH = @PKG_CONFIG_PATH@
+POSUB = @POSUB@
+RANLIB = @RANLIB@
+SENDMAIL = @SENDMAIL@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+SHRED = @SHRED@
+SQLITE3_CFLAGS = @SQLITE3_CFLAGS@
+SQLITE3_LIBS = @SQLITE3_LIBS@
+STRIP = @STRIP@
+SYSROOT = @SYSROOT@
+SYS_SOCKET_H = @SYS_SOCKET_H@
+TAR = @TAR@
+USE_C99_CFLAGS = @USE_C99_CFLAGS@
+USE_INCLUDED_LIBINTL = @USE_INCLUDED_LIBINTL@
+USE_NLS = @USE_NLS@
+VERSION = @VERSION@
+W32SOCKLIBS = @W32SOCKLIBS@
+WINDRES = @WINDRES@
+XGETTEXT = @XGETTEXT@
+XGETTEXT_015 = @XGETTEXT_015@
+XGETTEXT_EXTRA_OPTIONS = @XGETTEXT_EXTRA_OPTIONS@
+YAT2M = @YAT2M@
+ZLIBS = @ZLIBS@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_CC = @ac_ct_CC@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+localedir = $(datadir)/locale
+localstatedir = @localstatedir@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+runstatedir = @runstatedir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+EXTRA_DIST = \
+ LICENSE.TinySCHEME \
+ Manual.txt \
+ ffi.scm \
+ init.scm \
+ lib.scm \
+ makefile.scm \
+ repl.scm \
+ t-child.scm \
+ xml.scm \
+ tests.scm \
+ gnupg.scm \
+ time.scm
+
+
+# NB: AM_CFLAGS may also be used by tools running on the build
+# platform to create source files.
+AM_CPPFLAGS = -I$(top_srcdir)/common -DLOCALEDIR=\"$(localedir)\" \
+ $(am__append_1) $(am__append_2) $(am__append_3) \
+ $(am__append_4) $(am__append_5) $(am__append_6) \
+ $(am__append_7)
+@HAVE_W32CE_SYSTEM_FALSE@extra_sys_libs =
+
+# Under Windows we use LockFileEx. WindowsCE provides this only on
+# the WindowsMobile 6 platform and thus we need to use the coredll6
+# import library. We also want to use a stacksize of 256k instead of
+# the 2MB which is the default with cegcc. 256k is the largest stack
+# we use with pth.
+@HAVE_W32CE_SYSTEM_TRUE@extra_sys_libs = -lcoredll6
+@HAVE_W32CE_SYSTEM_FALSE@extra_bin_ldflags =
+@HAVE_W32CE_SYSTEM_TRUE@extra_bin_ldflags = -Wl,--stack=0x40000
+resource_objs =
+
+# Convenience macros
+libcommon = ../common/libcommon.a
+libcommonpth = ../common/libcommonpth.a
+libcommontls = ../common/libcommontls.a
+libcommontlsnpth = ../common/libcommontlsnpth.a
+AM_CFLAGS =
+CLEANFILES =
+common_libs = ../$(libcommon)
+commonpth_libs = ../$(libcommonpth)
+gpgscm_CFLAGS = -imacros scheme-config.h \
+ $(LIBGCRYPT_CFLAGS) $(LIBASSUAN_CFLAGS) $(GPG_ERROR_CFLAGS)
+
+gpgscm_SOURCES = main.c private.h ffi.c ffi.h ffi-private.h \
+ scheme-config.h scheme.c scheme.h scheme-private.h \
+ opdefines.h small-integers.h
+
+gpgscm_LDADD = $(LDADD) $(common_libs) \
+ $(NETLIBS) $(LIBICONV) $(LIBREADLINE) $(LIBINTL) \
+ $(LIBGCRYPT_LIBS) $(GPG_ERROR_LIBS)
+
+t_child_SOURCES = t-child.c
+all: all-am
+
+.SUFFIXES:
+.SUFFIXES: .c .o .obj .rc
+$(srcdir)/Makefile.in: @MAINTAINER_MODE_TRUE@ $(srcdir)/Makefile.am $(top_srcdir)/am/cmacros.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu tests/gpgscm/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --gnu tests/gpgscm/Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \
+ esac;
+$(top_srcdir)/am/cmacros.am $(am__empty):
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: @MAINTAINER_MODE_TRUE@ $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): @MAINTAINER_MODE_TRUE@ $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-binPROGRAMS: $(bin_PROGRAMS)
+ @$(NORMAL_INSTALL)
+ @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \
+ fi; \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed 's/$(EXEEXT)$$//' | \
+ while read p p1; do if test -f $$p \
+ ; then echo "$$p"; echo "$$p"; else :; fi; \
+ done | \
+ sed -e 'p;s,.*/,,;n;h' \
+ -e 's|.*|.|' \
+ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \
+ sed 'N;N;N;s,\n, ,g' | \
+ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \
+ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
+ if ($$2 == $$4) files[d] = files[d] " " $$1; \
+ else { print "f", $$3 "/" $$4, $$1; } } \
+ END { for (d in files) print "f", d, files[d] }' | \
+ while read type dir files; do \
+ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \
+ test -z "$$files" || { \
+ echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(bindir)$$dir'"; \
+ $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \
+ } \
+ ; done
+
+uninstall-binPROGRAMS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
+ files=`for p in $$list; do echo "$$p"; done | \
+ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \
+ -e 's/$$/$(EXEEXT)/' \
+ `; \
+ test -n "$$list" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(bindir)" && rm -f $$files
+
+clean-binPROGRAMS:
+ -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS)
+
+clean-noinstPROGRAMS:
+ -test -z "$(noinst_PROGRAMS)" || rm -f $(noinst_PROGRAMS)
+
+gpgscm$(EXEEXT): $(gpgscm_OBJECTS) $(gpgscm_DEPENDENCIES) $(EXTRA_gpgscm_DEPENDENCIES)
+ @rm -f gpgscm$(EXEEXT)
+ $(AM_V_CCLD)$(gpgscm_LINK) $(gpgscm_OBJECTS) $(gpgscm_LDADD) $(LIBS)
+
+t-child$(EXEEXT): $(t_child_OBJECTS) $(t_child_DEPENDENCIES) $(EXTRA_t_child_DEPENDENCIES)
+ @rm -f t-child$(EXEEXT)
+ $(AM_V_CCLD)$(LINK) $(t_child_OBJECTS) $(t_child_LDADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gpgscm-ffi.Po@am__quote@ # am--include-marker
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gpgscm-main.Po@am__quote@ # am--include-marker
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/gpgscm-scheme.Po@am__quote@ # am--include-marker
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/t-child.Po@am__quote@ # am--include-marker
+
+$(am__depfiles_remade):
+ @$(MKDIR_P) $(@D)
+ @echo '# dummy' >$@-t && $(am__mv) $@-t $@
+
+am--depfiles: $(am__depfiles_remade)
+
+.c.o:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ $<
+
+.c.obj:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c -o $@ `$(CYGPATH_W) '$<'`
+
+gpgscm-main.o: main.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-main.o -MD -MP -MF $(DEPDIR)/gpgscm-main.Tpo -c -o gpgscm-main.o `test -f 'main.c' || echo '$(srcdir)/'`main.c
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-main.Tpo $(DEPDIR)/gpgscm-main.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='main.c' object='gpgscm-main.o' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-main.o `test -f 'main.c' || echo '$(srcdir)/'`main.c
+
+gpgscm-main.obj: main.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-main.obj -MD -MP -MF $(DEPDIR)/gpgscm-main.Tpo -c -o gpgscm-main.obj `if test -f 'main.c'; then $(CYGPATH_W) 'main.c'; else $(CYGPATH_W) '$(srcdir)/main.c'; fi`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-main.Tpo $(DEPDIR)/gpgscm-main.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='main.c' object='gpgscm-main.obj' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-main.obj `if test -f 'main.c'; then $(CYGPATH_W) 'main.c'; else $(CYGPATH_W) '$(srcdir)/main.c'; fi`
+
+gpgscm-ffi.o: ffi.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-ffi.o -MD -MP -MF $(DEPDIR)/gpgscm-ffi.Tpo -c -o gpgscm-ffi.o `test -f 'ffi.c' || echo '$(srcdir)/'`ffi.c
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-ffi.Tpo $(DEPDIR)/gpgscm-ffi.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ffi.c' object='gpgscm-ffi.o' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-ffi.o `test -f 'ffi.c' || echo '$(srcdir)/'`ffi.c
+
+gpgscm-ffi.obj: ffi.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-ffi.obj -MD -MP -MF $(DEPDIR)/gpgscm-ffi.Tpo -c -o gpgscm-ffi.obj `if test -f 'ffi.c'; then $(CYGPATH_W) 'ffi.c'; else $(CYGPATH_W) '$(srcdir)/ffi.c'; fi`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-ffi.Tpo $(DEPDIR)/gpgscm-ffi.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='ffi.c' object='gpgscm-ffi.obj' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-ffi.obj `if test -f 'ffi.c'; then $(CYGPATH_W) 'ffi.c'; else $(CYGPATH_W) '$(srcdir)/ffi.c'; fi`
+
+gpgscm-scheme.o: scheme.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-scheme.o -MD -MP -MF $(DEPDIR)/gpgscm-scheme.Tpo -c -o gpgscm-scheme.o `test -f 'scheme.c' || echo '$(srcdir)/'`scheme.c
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-scheme.Tpo $(DEPDIR)/gpgscm-scheme.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='scheme.c' object='gpgscm-scheme.o' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-scheme.o `test -f 'scheme.c' || echo '$(srcdir)/'`scheme.c
+
+gpgscm-scheme.obj: scheme.c
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -MT gpgscm-scheme.obj -MD -MP -MF $(DEPDIR)/gpgscm-scheme.Tpo -c -o gpgscm-scheme.obj `if test -f 'scheme.c'; then $(CYGPATH_W) 'scheme.c'; else $(CYGPATH_W) '$(srcdir)/scheme.c'; fi`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/gpgscm-scheme.Tpo $(DEPDIR)/gpgscm-scheme.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='scheme.c' object='gpgscm-scheme.obj' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(gpgscm_CFLAGS) $(CFLAGS) -c -o gpgscm-scheme.obj `if test -f 'scheme.c'; then $(CYGPATH_W) 'scheme.c'; else $(CYGPATH_W) '$(srcdir)/scheme.c'; fi`
+
+ID: $(am__tagged_files)
+ $(am__define_uniq_tagged_files); mkid -fID $$unique
+tags: tags-am
+TAGS: tags
+
+tags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+ set x; \
+ here=`pwd`; \
+ $(am__define_uniq_tagged_files); \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: ctags-am
+
+CTAGS: ctags
+ctags-am: $(TAGS_DEPENDENCIES) $(am__tagged_files)
+ $(am__define_uniq_tagged_files); \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+cscopelist: cscopelist-am
+
+cscopelist-am: $(am__tagged_files)
+ list='$(am__tagged_files)'; \
+ case "$(srcdir)" in \
+ [\\/]* | ?:[\\/]*) sdir="$(srcdir)" ;; \
+ *) sdir=$(subdir)/$(srcdir) ;; \
+ esac; \
+ for i in $$list; do \
+ if test -f "$$i"; then \
+ echo "$(subdir)/$$i"; \
+ else \
+ echo "$$sdir/$$i"; \
+ fi; \
+ done >> $(top_builddir)/cscope.files
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(BUILT_SOURCES)
+ $(MAKE) $(AM_MAKEFLAGS) distdir-am
+
+distdir-am: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+ $(MAKE) $(AM_MAKEFLAGS) check-local
+check: check-am
+all-am: Makefile $(PROGRAMS)
+installdirs:
+ for dir in "$(DESTDIR)$(bindir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ if test -z '$(STRIP)'; then \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ install; \
+ else \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \
+ fi
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+clean: clean-am
+
+clean-am: clean-binPROGRAMS clean-generic clean-noinstPROGRAMS \
+ mostlyclean-am
+
+distclean: distclean-am
+ -rm -f ./$(DEPDIR)/gpgscm-ffi.Po
+ -rm -f ./$(DEPDIR)/gpgscm-main.Po
+ -rm -f ./$(DEPDIR)/gpgscm-scheme.Po
+ -rm -f ./$(DEPDIR)/t-child.Po
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am:
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-binPROGRAMS
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -f ./$(DEPDIR)/gpgscm-ffi.Po
+ -rm -f ./$(DEPDIR)/gpgscm-main.Po
+ -rm -f ./$(DEPDIR)/gpgscm-scheme.Po
+ -rm -f ./$(DEPDIR)/t-child.Po
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-binPROGRAMS
+
+.MAKE: check-am install-am install-strip
+
+.PHONY: CTAGS GTAGS TAGS all all-am am--depfiles check check-am \
+ check-local clean clean-binPROGRAMS clean-generic \
+ clean-noinstPROGRAMS cscopelist-am ctags ctags-am distclean \
+ distclean-compile distclean-generic distclean-tags distdir dvi \
+ dvi-am html html-am info info-am install install-am \
+ install-binPROGRAMS install-data install-data-am install-dvi \
+ install-dvi-am install-exec install-exec-am install-html \
+ install-html-am install-info install-info-am install-man \
+ install-pdf install-pdf-am install-ps install-ps-am \
+ install-strip installcheck installcheck-am installdirs \
+ maintainer-clean maintainer-clean-generic mostlyclean \
+ mostlyclean-compile mostlyclean-generic pdf pdf-am ps ps-am \
+ tags tags-am uninstall uninstall-am uninstall-binPROGRAMS
+
+.PRECIOUS: Makefile
+
+
+@HAVE_W32_SYSTEM_TRUE@.rc.o:
+@HAVE_W32_SYSTEM_TRUE@ $(WINDRES) $(DEFAULT_INCLUDES) $(INCLUDES) "$<" "$@"
+
+# Make sure that all libs are build before we use them. This is
+# important for things like make -j2.
+$(PROGRAMS): $(common_libs)
+
+check-local: gpgscm$(EXEEXT) t-child$(EXEEXT)
+ EXEEXT=$(EXEEXT) GPGSCM_PATH=$(srcdir) \
+ ./gpgscm$(EXEEXT) $(srcdir)/t-child.scm
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
diff --git a/tests/gpgscm/Manual.txt b/tests/gpgscm/Manual.txt
new file mode 100644
index 0000000..b146926
--- /dev/null
+++ b/tests/gpgscm/Manual.txt
@@ -0,0 +1,444 @@
+
+
+ TinySCHEME Version 1.41
+
+ "Safe if used as prescribed"
+ -- Philip K. Dick, "Ubik"
+
+This software is open source, covered by a BSD-style license.
+Please read accompanying file COPYING.
+-------------------------------------------------------------------------------
+
+ This Scheme interpreter is based on MiniSCHEME version 0.85k4
+ (see miniscm.tar.gz in the Scheme Repository)
+ Original credits in file MiniSCHEMETribute.txt.
+
+ D. Souflis (dsouflis@acm.org)
+
+-------------------------------------------------------------------------------
+ What is TinyScheme?
+ -------------------
+
+ TinyScheme is a lightweight Scheme interpreter that implements as large
+ a subset of R5RS as was possible without getting very large and
+ complicated. It is meant to be used as an embedded scripting interpreter
+ for other programs. As such, it does not offer IDEs or extensive toolkits
+ although it does sport a small top-level loop, included conditionally.
+ A lot of functionality in TinyScheme is included conditionally, to allow
+ developers freedom in balancing features and footprint.
+
+ As an embedded interpreter, it allows multiple interpreter states to
+ coexist in the same program, without any interference between them.
+ Programmatically, foreign functions in C can be added and values
+ can be defined in the Scheme environment. Being a quite small program,
+ it is easy to comprehend, get to grips with, and use.
+
+ Known bugs
+ ----------
+
+ TinyScheme is known to misbehave when memory is exhausted.
+
+
+ Things that keep missing, or that need fixing
+ ---------------------------------------------
+
+ There are no hygienic macros. No rational or
+ complex numbers. No unwind-protect and call-with-values.
+
+ Maybe (a subset of) SLIB will work with TinySCHEME...
+
+ Decent debugging facilities are missing. Only tracing is supported
+ natively.
+
+
+ Scheme Reference
+ ----------------
+
+ If something seems to be missing, please refer to the code and
+ "init.scm", since some are library functions. Refer to the MiniSCHEME
+ readme as a last resort.
+
+ Environments
+ (interaction-environment)
+ See R5RS. In TinySCHEME, immutable list of association lists.
+
+ (current-environment)
+ The environment in effect at the time of the call. An example of its
+ use and its utility can be found in the sample code that implements
+ packages in "init.scm":
+
+ (macro (package form)
+ `(apply (lambda ()
+ ,@(cdr form)
+ (current-environment))))
+
+ The environment containing the (local) definitions inside the closure
+ is returned as an immutable value.
+
+ (defined? <symbol>) (defined? <symbol> <environment>)
+ Checks whether the given symbol is defined in the current (or given)
+ environment.
+
+ Symbols
+ (gensym)
+ Returns a new interned symbol each time. Will probably move to the
+ library when string->symbol is implemented.
+
+ Directives
+ (gc)
+ Performs garbage collection immediately.
+
+ (gc-verbose) (gc-verbose <bool>)
+ The argument (defaulting to #t) controls whether GC produces
+ visible outcome.
+
+ (quit) (quit <num>)
+ Stops the interpreter and sets the 'retcode' internal field (defaults
+ to 0). When standalone, 'retcode' is returned as exit code to the OS.
+
+ (tracing <num>)
+ 1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1).
+
+ Mathematical functions
+ Since rationals and complexes are absent, the respective functions
+ are also missing.
+ Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling,
+ trunc, round and also sqrt and expt when USE_MATH=1.
+ Number-theoretical quotient, remainder and modulo, gcd, lcm.
+ Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?,
+ exact->inexact. inexact->exact is a core function.
+
+ Type predicates
+ boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?,
+ char?,port?,input-port?,output-port?,procedure?,pair?,environment?',
+ vector?. Also closure?, macro?.
+
+ Types
+ Types supported:
+
+ Numbers (integers and reals)
+ Symbols
+ Pairs
+ Strings
+ Characters
+ Ports
+ Eof object
+ Environments
+ Vectors
+
+ Literals
+ String literals can contain escaped quotes \" as usual, but also
+ \n, \r, \t, \xDD (hex representations) and \DDD (octal representations).
+ Note also that it is possible to include literal newlines in string
+ literals, e.g.
+
+ (define s "String with newline here
+ and here
+ that can function like a HERE-string")
+
+ Character literals contain #\space and #\newline and are supplemented
+ with #\return and #\tab, with obvious meanings. Hex character
+ representations are allowed (e.g. #\x20 is #\space).
+ When USE_ASCII_NAMES is defined, various control characters can be
+ referred to by their ASCII name.
+ 0 #\nul 17 #\dc1
+ 1 #\soh 18 #\dc2
+ 2 #\stx 19 #\dc3
+ 3 #\etx 20 #\dc4
+ 4 #\eot 21 #\nak
+ 5 #\enq 22 #\syn
+ 6 #\ack 23 #\etv
+ 7 #\bel 24 #\can
+ 8 #\bs 25 #\em
+ 9 #\ht 26 #\sub
+ 10 #\lf 27 #\esc
+ 11 #\vt 28 #\fs
+ 12 #\ff 29 #\gs
+ 13 #\cr 30 #\rs
+ 14 #\so 31 #\us
+ 15 #\si
+ 16 #\dle 127 #\del
+
+ Numeric literals support #x #o #b and #d. Flonums are currently read only
+ in decimal notation. Full grammar will be supported soon.
+
+ Quote, quasiquote etc.
+ As usual.
+
+ Immutable values
+ Immutable pairs cannot be modified by set-car! and set-cdr!.
+ Immutable strings cannot be modified via string-set!
+
+ I/O
+ As per R5RS, plus String Ports (see below).
+ current-input-port, current-output-port,
+ close-input-port, close-output-port, input-port?, output-port?,
+ open-input-file, open-output-file.
+ read, write, display, newline, write-char, read-char, peek-char.
+ char-ready? returns #t only for string ports, because there is no
+ portable way in stdio to determine if a character is available.
+ Also open-input-output-file, set-input-port, set-output-port (not R5RS)
+ Library: call-with-input-file, call-with-output-file,
+ with-input-from-file, with-output-from-file and
+ with-input-output-from-to-files, close-port and input-output-port?
+ (not R5RS).
+ String Ports: open-input-string, open-output-string, get-output-string,
+ open-input-output-string. Strings can be used with I/O routines.
+
+ Vectors
+ make-vector, vector, vector-length, vector-ref, vector-set!, list->vector,
+ vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS)
+
+ Strings
+ string, make-string, list->string, string-length, string-ref, string-set!,
+ substring, string->list, string-fill!, string-append, string-copy.
+ string=?, string<?, string>?, string>?, string<=?, string>=?.
+ (No string-ci*? yet). string->number, number->string. Also atom->string,
+ string->atom (not R5RS).
+
+ Symbols
+ symbol->string, string->symbol
+
+ Characters
+ integer->char, char->integer.
+ char=?, char<?, char>?, char<=?, char>=?.
+ (No char-ci*?)
+
+ Pairs & Lists
+ cons, car, cdr, list, length, map, for-each, foldr, list-tail,
+ list-ref, last-pair, reverse, append.
+ Also member, memq, memv, based on generic-member, assoc, assq, assv
+ based on generic-assoc.
+
+ Streams
+ head, tail, cons-stream
+
+ Control features
+ Apart from procedure?, also macro? and closure?
+ map, for-each, force, delay, call-with-current-continuation (or call/cc),
+ eval, apply. 'Forcing' a value that is not a promise produces the value.
+ There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in
+ the presence of continuations would require support from the abstract
+ machine itself.
+
+ Property lists
+ TinyScheme inherited from MiniScheme property lists for symbols.
+ put, get.
+
+ Dynamically-loaded extensions
+ (load-extension <filename without extension>)
+ Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
+ of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
+ the library in a directory other than the current one. Please refer to the
+ appropriate 'man' page.
+
+ Esoteric procedures
+ (oblist)
+ Returns the oblist, an immutable list of all the symbols.
+
+ (macro-expand <form>)
+ Returns the expanded form of the macro call denoted by the argument
+
+ (define-with-return (<procname> <args>...) <body>)
+ Like plain 'define', but makes the continuation available as 'return'
+ inside the procedure. Handy for imperative programs.
+
+ (new-segment <num>)
+ Allocates more memory segments.
+
+ defined?
+ See "Environments"
+
+ (get-closure-code <closure>)
+ Gets the code as scheme data.
+
+ (make-closure <code> <environment>)
+ Makes a new closure in the given environment.
+
+ Obsolete procedures
+ (print-width <object>)
+
+ Programmer's Reference
+ ----------------------
+
+ The interpreter state is initialized with "scheme_init".
+ Custom memory allocation routines can be installed with an alternate
+ initialization function: "scheme_init_custom_alloc".
+ Files can be loaded with "scheme_load_file". Strings containing Scheme
+ code can be loaded with "scheme_load_string". It is a good idea to
+ "scheme_load" init.scm before anything else.
+
+ External data for keeping external state (of use to foreign functions)
+ can be installed with "scheme_set_external_data".
+ Foreign functions are installed with "assign_foreign". Additional
+ definitions can be added to the interpreter state, with "scheme_define"
+ (this is the way HTTP header data and HTML form data are passed to the
+ Scheme script in the Altera SQL Server). If you wish to define the
+ foreign function in a specific environment (to enhance modularity),
+ use "assign_foreign_env".
+
+ The procedure "scheme_apply0" has been added with persistent scripts in
+ mind. Persistent scripts are loaded once, and every time they are needed
+ to produce HTTP output, appropriate data are passed through global
+ definitions and function "main" is called to do the job. One could
+ add easily "scheme_apply1" etc.
+
+ The interpreter state should be deinitialized with "scheme_deinit".
+
+ DLLs containing foreign functions should define a function named
+ init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
+ should define init_bar. This function should assign_foreign any foreign
+ function contained in the DLL.
+
+ The first dynamically loaded extension available for TinyScheme is
+ a regular expression library. Although it's by no means an
+ established standard, this library is supposed to be installed in
+ a directory mirroring its name under the TinyScheme location.
+
+
+ Foreign Functions
+ -----------------
+
+ The user can add foreign functions in C. For example, a function
+ that squares its argument:
+
+ pointer square(scheme *sc, pointer args) {
+ if(args!=sc->NIL) {
+ if(sc->isnumber(sc->pair_car(args))) {
+ double v=sc->rvalue(sc->pair_car(args));
+ return sc->mk_real(sc,v*v);
+ }
+ }
+ return sc->NIL;
+ }
+
+ Foreign functions are now defined as closures:
+
+ sc->interface->scheme_define(
+ sc,
+ sc->global_env,
+ sc->interface->mk_symbol(sc,"square"),
+ sc->interface->mk_foreign_func(sc, square));
+
+
+ Foreign functions can use the external data in the "scheme" struct
+ to implement any kind of external state.
+
+ External data are set with the following function:
+ void scheme_set_external_data(scheme *sc, void *p);
+
+ As of v.1.17, the canonical way for a foreign function in a DLL to
+ manipulate Scheme data is using the function pointers in sc->interface.
+
+ Standalone
+ ----------
+
+ Usage: tinyscheme -?
+ or: tinyscheme [<file1> <file2> ...]
+ followed by
+ -1 <file> [<arg1> <arg2> ...]
+ -c <Scheme commands> [<arg1> <arg2> ...]
+ assuming that the executable is named tinyscheme.
+
+ Use - in the place of a filename to denote stdin.
+ The -1 flag is meant for #! usage in shell scripts. If you specify
+ #! /somewhere/tinyscheme -1
+ then tinyscheme will be called to process the file. For example, the
+ following script echoes the Scheme list of its arguments.
+
+ #! /somewhere/tinyscheme -1
+ (display *args*)
+
+ The -c flag permits execution of arbitrary Scheme code.
+
+
+ Error Handling
+ --------------
+
+ Errors are recovered from without damage. The user can install his
+ own handler for system errors, by defining *error-hook*. Defining
+ to '() gives the default behavior, which is equivalent to "error".
+ USE_ERROR_HOOK must be defined.
+
+ A simple exception handling mechanism can be found in "init.scm".
+ A new syntactic form is introduced:
+
+ (catch <expr returned exceptionally>
+ <expr1> <expr2> ... <exprN>)
+
+ "Catch" establishes a scope spanning multiple call-frames
+ until another "catch" is encountered.
+
+ Exceptions are thrown with:
+
+ (throw "message")
+
+ If used outside a (catch ...), reverts to (error "message").
+
+ Example of use:
+
+ (define (foo x) (write x) (newline) (/ x 0))
+
+ (catch (begin (display "Error!\n") 0)
+ (write "Before foo ... ")
+ (foo 5)
+ (write "After foo"))
+
+ The exception mechanism can be used even by system errors, by
+
+ (define *error-hook* throw)
+
+ which makes use of the error hook described above.
+
+ If necessary, the user can devise his own exception mechanism with
+ tagged exceptions etc.
+
+
+ Reader extensions
+ -----------------
+
+ When encountering an unknown character after '#', the user-specified
+ procedure *sharp-hook* (if any), is called to read the expression.
+ This can be used to extend the reader to handle user-defined constants
+ or whatever. It should be a procedure without arguments, reading from
+ the current input port (which will be the load-port).
+
+
+ Colon Qualifiers - Packages
+ ---------------------------
+
+ When USE_COLON_HOOK=1:
+ The lexer now recognizes the construction <qualifier>::<symbol> and
+ transforms it in the following manner (T is the transformation function):
+
+ T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
+
+ where <qualifier> is a symbol not containing any double-colons.
+
+ As the definition is recursive, qualifiers can be nested.
+ The user can define his own *colon-hook*, to handle qualified names.
+ By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
+ the qualifier must denote a Scheme environment, such as one returned
+ by (interaction-environment). "Init.scm" defines a new syntantic form,
+ PACKAGE, as a simple example. It is used like this:
+
+ (define toto
+ (package
+ (define foo 1)
+ (define bar +)))
+
+ foo ==> Error, "foo" undefined
+ (eval 'foo) ==> Error, "foo" undefined
+ (eval 'foo toto) ==> 1
+ toto::foo ==> 1
+ ((eval 'bar toto) 2 (eval 'foo toto)) ==> 3
+ (toto::bar 2 toto::foo) ==> 3
+ (eval (bar 2 foo) toto) ==> 3
+
+ If the user installs another package infrastructure, he must define
+ a new 'package' procedure or macro to retain compatibility with supplied
+ code.
+
+ Note: Older versions used ':' as a qualifier. Unfortunately, the use
+ of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
+ precludes its use as a real qualifier.
diff --git a/tests/gpgscm/ffi-private.h b/tests/gpgscm/ffi-private.h
new file mode 100644
index 0000000..037da56
--- /dev/null
+++ b/tests/gpgscm/ffi-private.h
@@ -0,0 +1,148 @@
+/* FFI interface for TinySCHEME.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef GPGSCM_FFI_PRIVATE_H
+#define GPGSCM_FFI_PRIVATE_H
+
+#include <gpg-error.h>
+#include "scheme.h"
+#include "scheme-private.h"
+
+#define FFI_PROLOG() \
+ unsigned int ffi_arg_index GPGRT_ATTR_UNUSED = 1; \
+ int err GPGRT_ATTR_UNUSED = 0 \
+
+int ffi_bool_value (scheme *sc, pointer p);
+
+#define CONVERSION_number(SC, X) (SC)->vptr->ivalue (X)
+#define CONVERSION_string(SC, X) (SC)->vptr->string_value (X)
+#define CONVERSION_character(SC, X) (SC)->vptr->charvalue (X)
+#define CONVERSION_list(SC, X) (X)
+#define CONVERSION_bool(SC, X) ffi_bool_value ((SC), (X))
+#define CONVERSION_path(SC, X) (((SC)->vptr->is_string (X) \
+ ? (SC)->vptr->string_value \
+ : (SC)->vptr->symname) (X))
+
+#define IS_A_number(SC, X) (SC)->vptr->is_number (X)
+#define IS_A_string(SC, X) (SC)->vptr->is_string (X)
+#define IS_A_character(SC, X) (SC)->vptr->is_character (X)
+#define IS_A_list(SC, X) (SC)->vptr->is_list ((SC), X)
+#define IS_A_bool(SC, X) ((X) == (SC)->F || (X) == (SC)->T)
+#define IS_A_path(SC, X) ((SC)->vptr->is_string (X) \
+ || (SC)->vptr->is_symbol (X))
+
+#define FFI_ARG_OR_RETURN(SC, CTYPE, TARGET, WANT, ARGS) \
+ do { \
+ if ((ARGS) == (SC)->NIL) \
+ return (SC)->vptr->mk_string ((SC), \
+ "too few arguments: want " \
+ #TARGET "("#WANT"/"#CTYPE")\n"); \
+ if (! IS_A_##WANT ((SC), pair_car (ARGS))) { \
+ char ffi_error_message[256]; \
+ snprintf (ffi_error_message, sizeof ffi_error_message, \
+ "argument %d must be: " #WANT "\n", ffi_arg_index); \
+ return (SC)->vptr->mk_string ((SC), ffi_error_message); \
+ } \
+ TARGET = CONVERSION_##WANT (SC, pair_car (ARGS)); \
+ ARGS = pair_cdr (ARGS); \
+ ffi_arg_index += 1; \
+ } while (0)
+
+#define FFI_ARGS_DONE_OR_RETURN(SC, ARGS) \
+ do { \
+ if ((ARGS) != (SC)->NIL) \
+ return (SC)->vptr->mk_string ((SC), "too many arguments"); \
+ } while (0)
+
+#define FFI_RETURN_ERR(SC, ERR) \
+ return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1)
+
+#define FFI_RETURN(SC) FFI_RETURN_ERR (SC, err)
+
+#define FFI_RETURN_POINTER(SC, X) \
+ return _cons ((SC), mk_integer ((SC), err), \
+ _cons ((SC), (X), (SC)->NIL, 1), 1)
+#define FFI_RETURN_INT(SC, X) \
+ FFI_RETURN_POINTER ((SC), mk_integer ((SC), (X)))
+#define FFI_RETURN_STRING(SC, X) \
+ FFI_RETURN_POINTER ((SC), mk_string ((SC), (X)))
+
+char *ffi_schemify_name (const char *s, int macro);
+
+void ffi_scheme_eval (scheme *sc, const char *format, ...)
+ GPGRT_ATTR_PRINTF (2, 3);
+pointer ffi_sprintf (scheme *sc, const char *format, ...)
+ GPGRT_ATTR_PRINTF (2, 3);
+
+#define ffi_define_function_name(SC, NAME, F) \
+ do { \
+ char *_fname = ffi_schemify_name ("__" #F, 0); \
+ scheme_define ((SC), \
+ (SC)->global_env, \
+ mk_symbol ((SC), _fname), \
+ mk_foreign_func ((SC), (do_##F))); \
+ ffi_scheme_eval ((SC), \
+ "(define (%s . a) (ffi-apply \"%s\" %s a))", \
+ (NAME), (NAME), _fname); \
+ free (_fname); \
+ } while (0)
+
+#define ffi_define_function(SC, F) \
+ do { \
+ char *_name = ffi_schemify_name (#F, 0); \
+ ffi_define_function_name ((SC), _name, F); \
+ free (_name); \
+ } while (0)
+
+#define ffi_define_constant(SC, C) \
+ do { \
+ char *_name = ffi_schemify_name (#C, 1); \
+ scheme_define ((SC), \
+ (SC)->global_env, \
+ mk_symbol ((SC), _name), \
+ mk_integer ((SC), (C))); \
+ free (_name); \
+ } while (0)
+
+#define ffi_define(SC, SYM, EXP) \
+ scheme_define ((SC), (SC)->global_env, mk_symbol ((SC), (SYM)), EXP)
+
+#define ffi_define_variable_pointer(SC, C, P) \
+ do { \
+ char *_name = ffi_schemify_name (#C, 0); \
+ scheme_define ((SC), \
+ (SC)->global_env, \
+ mk_symbol ((SC), _name), \
+ (P)); \
+ free (_name); \
+ } while (0)
+
+#define ffi_define_variable_integer(SC, C) \
+ ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_integer ((SC), C))
+
+#define ffi_define_variable_string(SC, C) \
+ ffi_define_variable_pointer ((SC), C, (SC)->vptr->mk_string ((SC), C ?: ""))
+
+gpg_error_t ffi_list2argv (scheme *sc, pointer list,
+ char ***argv, size_t *len);
+gpg_error_t ffi_list2intv (scheme *sc, pointer list,
+ int **intv, size_t *len);
+
+#endif /* GPGSCM_FFI_PRIVATE_H */
diff --git a/tests/gpgscm/ffi.c b/tests/gpgscm/ffi.c
new file mode 100644
index 0000000..dde5b52
--- /dev/null
+++ b/tests/gpgscm/ffi.c
@@ -0,0 +1,1470 @@
+/* FFI interface for TinySCHEME.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#include <config.h>
+
+#include <assert.h>
+#include <ctype.h>
+#include <dirent.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <gpg-error.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#if HAVE_LIBREADLINE
+#define GNUPG_LIBREADLINE_H_INCLUDED
+#include <readline/readline.h>
+#include <readline/history.h>
+#endif
+
+#include "../../common/util.h"
+#include "../../common/exechelp.h"
+#include "../../common/sysutils.h"
+
+#include "private.h"
+#include "ffi.h"
+#include "ffi-private.h"
+
+/* For use in nice error messages. */
+static const char *
+ordinal_suffix (int n)
+{
+ switch (n)
+ {
+ case 1: return "st";
+ case 2: return "nd";
+ case 3: return "rd";
+ default: return "th";
+ }
+ assert (! "reached");
+}
+
+
+
+int
+ffi_bool_value (scheme *sc, pointer p)
+{
+ return ! (p == sc->F);
+}
+
+
+
+static pointer
+do_logand (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = ~0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc &= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_logior (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = 0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc |= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_logxor (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v, acc = 0;
+ while (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ acc ^= v;
+ }
+ FFI_RETURN_INT (sc, acc);
+}
+
+static pointer
+do_lognot (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int v;
+ FFI_ARG_OR_RETURN (sc, unsigned int, v, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, ~v);
+}
+
+/* User interface. */
+
+static pointer
+do_flush_stdio (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ fflush (stdout);
+ fflush (stderr);
+ FFI_RETURN (sc);
+}
+
+
+int use_libreadline;
+
+/* Read a string, and return a pointer to it. Returns NULL on EOF. */
+char *
+rl_gets (const char *prompt)
+{
+ static char *line = NULL;
+ char *p;
+ xfree (line);
+
+#if HAVE_LIBREADLINE
+ {
+ line = readline (prompt);
+ if (line && *line)
+ add_history (line);
+ }
+#else
+ {
+ size_t max_size = 0xff;
+ printf ("%s", prompt);
+ fflush (stdout);
+ line = xtrymalloc (max_size);
+ if (line != NULL)
+ fgets (line, max_size, stdin);
+ }
+#endif
+
+ /* Strip trailing whitespace. */
+ if (line && strlen (line) > 0)
+ for (p = &line[strlen (line) - 1]; isspace (*p); p--)
+ *p = 0;
+
+ return line;
+}
+
+static pointer
+do_prompt (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ const char *prompt;
+ const char *line;
+ FFI_ARG_OR_RETURN (sc, const char *, prompt, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ line = rl_gets (prompt);
+ if (! line)
+ FFI_RETURN_POINTER (sc, sc->EOF_OBJ);
+
+ FFI_RETURN_STRING (sc, line);
+}
+
+static pointer
+do_sleep (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ unsigned int seconds;
+ FFI_ARG_OR_RETURN (sc, unsigned int, seconds, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ sleep (seconds);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_usleep (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ useconds_t microseconds;
+ FFI_ARG_OR_RETURN (sc, useconds_t, microseconds, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ usleep (microseconds);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_chdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, path, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (chdir (name))
+ FFI_RETURN_ERR (sc, errno);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_strerror (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int error;
+ FFI_ARG_OR_RETURN (sc, int, error, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_STRING (sc, gpg_strerror (error));
+}
+
+static pointer
+do_getenv (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *value;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ value = getenv (name);
+ FFI_RETURN_STRING (sc, value ? value : "");
+}
+
+static pointer
+do_setenv (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *value;
+ int overwrite;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, value, string, args);
+ FFI_ARG_OR_RETURN (sc, int, overwrite, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (gnupg_setenv (name, value, overwrite))
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_exit (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int retcode;
+ FFI_ARG_OR_RETURN (sc, int, retcode, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ exit (retcode);
+}
+
+/* XXX: use gnupgs variant b/c mode as string */
+static pointer
+do_open (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ char *pathname;
+ int flags;
+ mode_t mode = 0;
+ FFI_ARG_OR_RETURN (sc, char *, pathname, path, args);
+ FFI_ARG_OR_RETURN (sc, int, flags, number, args);
+ if (args != sc->NIL)
+ FFI_ARG_OR_RETURN (sc, mode_t, mode, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ fd = open (pathname, flags, mode);
+ if (fd == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN_INT (sc, fd);
+}
+
+static pointer
+do_fdopen (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FILE *stream;
+ int fd;
+ char *mode;
+ int kind;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ stream = fdopen (fd, mode);
+ if (stream == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ if (setvbuf (stream, NULL, _IONBF, 0) != 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ kind = 0;
+ if (strchr (mode, 'r'))
+ kind |= port_input;
+ if (strchr (mode, 'w'))
+ kind |= port_output;
+
+ FFI_RETURN_POINTER (sc, sc->vptr->mk_port_from_file (sc, stream, kind));
+}
+
+static pointer
+do_close (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_ERR (sc, close (fd) == 0 ? 0 : gpg_error_from_syserror ());
+}
+
+static pointer
+do_seek (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int fd;
+ off_t offset;
+ int whence;
+ FFI_ARG_OR_RETURN (sc, int, fd, number, args);
+ FFI_ARG_OR_RETURN (sc, off_t, offset, number, args);
+ FFI_ARG_OR_RETURN (sc, int, whence, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_ERR (sc, lseek (fd, offset, whence) == (off_t) -1
+ ? gpg_error_from_syserror () : 0);
+}
+
+static pointer
+do_get_temp_path (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+#ifdef HAVE_W32_SYSTEM
+ char buffer[MAX_PATH+1];
+#endif
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+#ifdef HAVE_W32_SYSTEM
+ if (GetTempPath (MAX_PATH+1, buffer) == 0)
+ FFI_RETURN_STRING (sc, "/temp");
+ FFI_RETURN_STRING (sc, buffer);
+#else
+ FFI_RETURN_STRING (sc, "/tmp");
+#endif
+}
+
+static pointer
+do_mkdtemp (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *template;
+#ifdef PATH_MAX
+ char buffer[PATH_MAX];
+#else
+ char buffer[1024];
+#endif
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, template, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ if (strlen (template) > sizeof buffer - 1)
+ FFI_RETURN_ERR (sc, EINVAL);
+ strncpy (buffer, template, sizeof buffer);
+
+ name = gnupg_mkdtemp (buffer);
+ if (name == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN_STRING (sc, name);
+}
+
+static pointer
+do_unlink (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (unlink (name) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static gpg_error_t
+unlink_recursively (const char *name)
+{
+ gpg_error_t err = 0;
+ struct stat st;
+
+ if (stat (name, &st) == -1)
+ return gpg_error_from_syserror ();
+
+ if (S_ISDIR (st.st_mode))
+ {
+ DIR *dir;
+ struct dirent *dent;
+
+ dir = opendir (name);
+ if (dir == NULL)
+ return gpg_error_from_syserror ();
+
+ while ((dent = readdir (dir)))
+ {
+ char *child;
+
+ if (strcmp (dent->d_name, ".") == 0
+ || strcmp (dent->d_name, "..") == 0)
+ continue;
+
+ child = xtryasprintf ("%s/%s", name, dent->d_name);
+ if (child == NULL)
+ {
+ err = gpg_error_from_syserror ();
+ goto leave;
+ }
+
+ err = unlink_recursively (child);
+ xfree (child);
+ if (err == gpg_error_from_errno (ENOENT))
+ err = 0;
+ if (err)
+ goto leave;
+ }
+
+ leave:
+ closedir (dir);
+ if (! err)
+ rmdir (name);
+ return err;
+ }
+ else
+ if (unlink (name) == -1)
+ return gpg_error_from_syserror ();
+ return 0;
+}
+
+static pointer
+do_unlink_recursively (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = unlink_recursively (name);
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_rename (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *old;
+ char *new;
+ FFI_ARG_OR_RETURN (sc, char *, old, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, new, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (rename (old, new) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_getcwd (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer result;
+ char *cwd;
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ cwd = gnupg_getcwd ();
+ if (cwd == NULL)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ result = sc->vptr->mk_string (sc, cwd);
+ xfree (cwd);
+ FFI_RETURN_POINTER (sc, result);
+}
+
+static pointer
+do_mkdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ char *mode;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, mode, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (gnupg_mkdir (name, mode) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_rmdir (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *name;
+ FFI_ARG_OR_RETURN (sc, char *, name, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (rmdir (name) == -1)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_get_isotime (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ gnupg_isotime_t timebuf;
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ gnupg_get_isotime (timebuf);
+ FFI_RETURN_STRING (sc, timebuf);
+}
+
+static pointer
+do_get_time (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, gnupg_get_time ());
+}
+
+static pointer
+do_getpid (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, getpid ());
+}
+
+static pointer
+do_srandom (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int seed;
+ FFI_ARG_OR_RETURN (sc, int, seed, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ srand (seed);
+ FFI_RETURN (sc);
+}
+
+static int
+random_scaled (int scale)
+{
+ int v;
+#ifdef HAVE_RAND
+ v = rand ();
+#else
+ v = random ();
+#endif
+
+#ifndef RAND_MAX /* for SunOS */
+#define RAND_MAX 32767
+#endif
+
+ return ((int) (1 + (int) ((float) scale * v / (RAND_MAX + 1.0))) - 1);
+}
+
+static pointer
+do_random (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int scale;
+ FFI_ARG_OR_RETURN (sc, int, scale, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, random_scaled (scale));
+}
+
+static pointer
+do_make_random_string (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int size;
+ pointer chunk;
+ char *p;
+ FFI_ARG_OR_RETURN (sc, int, size, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ if (size < 0)
+ return ffi_sprintf (sc, "size must be positive");
+
+ chunk = sc->vptr->mk_counted_string (sc, NULL, size);
+ if (sc->no_memory)
+ FFI_RETURN_ERR (sc, ENOMEM);
+
+ for (p = sc->vptr->string_value (chunk); size; p++, size--)
+ *p = (char) random_scaled (256);
+ FFI_RETURN_POINTER (sc, chunk);
+}
+
+
+
+/* estream functions. */
+
+struct es_object_box
+{
+ estream_t stream;
+ int closed;
+};
+
+static void
+es_object_finalize (scheme *sc, void *data)
+{
+ struct es_object_box *box = data;
+ (void) sc;
+
+ if (! box->closed)
+ es_fclose (box->stream);
+ xfree (box);
+}
+
+static void
+es_object_to_string (scheme *sc, char *out, size_t size, void *data)
+{
+ struct es_object_box *box = data;
+ (void) sc;
+
+ snprintf (out, size, "#estream %p", box->stream);
+}
+
+static struct foreign_object_vtable es_object_vtable =
+ {
+ es_object_finalize,
+ es_object_to_string,
+ };
+
+static pointer
+es_wrap (scheme *sc, estream_t stream)
+{
+ struct es_object_box *box = xmalloc (sizeof *box);
+ if (box == NULL)
+ return sc->NIL;
+
+ box->stream = stream;
+ box->closed = 0;
+ return sc->vptr->mk_foreign_object (sc, &es_object_vtable, box);
+}
+
+static struct es_object_box *
+es_unwrap (scheme *sc, pointer object)
+{
+ (void) sc;
+
+ if (! is_foreign_object (object))
+ return NULL;
+
+ if (sc->vptr->get_foreign_object_vtable (object) != &es_object_vtable)
+ return NULL;
+
+ return sc->vptr->get_foreign_object_data (object);
+}
+
+#define CONVERSION_estream(SC, X) es_unwrap (SC, X)
+#define IS_A_estream(SC, X) es_unwrap (SC, X)
+
+static pointer
+do_es_fclose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = es_fclose (box->stream);
+ if (! err)
+ box->closed = 1;
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_es_read (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ size_t bytes_to_read;
+
+ pointer result;
+ void *buffer;
+ size_t bytes_read;
+
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARG_OR_RETURN (sc, size_t, bytes_to_read, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ buffer = xtrymalloc (bytes_to_read);
+ if (buffer == NULL)
+ FFI_RETURN_ERR (sc, ENOMEM);
+
+ err = es_read (box->stream, buffer, bytes_to_read, &bytes_read);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ result = sc->vptr->mk_counted_string (sc, buffer, bytes_read);
+ xfree (buffer);
+ FFI_RETURN_POINTER (sc, result);
+}
+
+static pointer
+do_es_feof (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ FFI_RETURN_POINTER (sc, es_feof (box->stream) ? sc->T : sc->F);
+}
+
+static pointer
+do_es_write (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ struct es_object_box *box;
+ const char *buffer;
+ size_t bytes_to_write, bytes_written;
+
+ FFI_ARG_OR_RETURN (sc, struct es_object_box *, box, estream, args);
+ /* XXX how to get the length of the string buffer? scheme strings
+ may contain \0. */
+ FFI_ARG_OR_RETURN (sc, const char *, buffer, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ bytes_to_write = strlen (buffer);
+ while (bytes_to_write > 0)
+ {
+ err = es_write (box->stream, buffer, bytes_to_write, &bytes_written);
+ if (err)
+ break;
+ bytes_to_write -= bytes_written;
+ buffer += bytes_written;
+ }
+
+ FFI_RETURN (sc);
+}
+
+
+
+/* Process handling. */
+
+static pointer
+do_spawn_process (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer arguments;
+ char **argv;
+ size_t len;
+ unsigned int flags;
+
+ estream_t infp;
+ estream_t outfp;
+ estream_t errfp;
+ pid_t pid;
+
+ FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
+ FFI_ARG_OR_RETURN (sc, unsigned int, flags, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ err = ffi_list2argv (sc, arguments, &argv, &len);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%luth element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) len);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ if (verbose > 1)
+ {
+ char **p;
+ fprintf (stderr, "Executing:");
+ for (p = argv; *p; p++)
+ fprintf (stderr, " '%s'", *p);
+ fprintf (stderr, "\n");
+ }
+
+ err = gnupg_spawn_process (argv[0], (const char **) &argv[1],
+ NULL,
+ NULL,
+ flags,
+ &infp, &outfp, &errfp, &pid);
+ xfree (argv);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+#define IMS(A, B) \
+ _cons (sc, es_wrap (sc, (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMS (infp,
+ IMS (outfp,
+ IMS (errfp,
+ IMC (pid, sc->NIL)))));
+#undef IMS
+#undef IMC
+}
+
+static pointer
+do_spawn_process_fd (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer arguments;
+ char **argv;
+ size_t len;
+ int infd, outfd, errfd;
+
+ pid_t pid;
+
+ FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
+ FFI_ARG_OR_RETURN (sc, int, infd, number, args);
+ FFI_ARG_OR_RETURN (sc, int, outfd, number, args);
+ FFI_ARG_OR_RETURN (sc, int, errfd, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ err = ffi_list2argv (sc, arguments, &argv, &len);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%luth element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) len);
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ if (verbose > 1)
+ {
+ char **p;
+ fprintf (stderr, "Executing:");
+ for (p = argv; *p; p++)
+ fprintf (stderr, " '%s'", *p);
+ fprintf (stderr, "\n");
+ }
+
+ err = gnupg_spawn_process_fd (argv[0], (const char **) &argv[1],
+ infd, outfd, errfd, &pid);
+ xfree (argv);
+ FFI_RETURN_INT (sc, pid);
+}
+
+static pointer
+do_wait_process (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ const char *name;
+ pid_t pid;
+ int hang;
+
+ int retcode;
+
+ FFI_ARG_OR_RETURN (sc, const char *, name, string, args);
+ FFI_ARG_OR_RETURN (sc, pid_t, pid, number, args);
+ FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_wait_process (name, pid, hang, &retcode);
+ if (err == GPG_ERR_GENERAL)
+ err = 0; /* Let the return code speak for itself. */
+
+ FFI_RETURN_INT (sc, retcode);
+}
+
+
+static pointer
+do_wait_processes (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer list_names;
+ char **names;
+ pointer list_pids;
+ size_t i, count;
+ pid_t *pids;
+ int hang;
+ int *retcodes;
+ pointer retcodes_list = sc->NIL;
+
+ FFI_ARG_OR_RETURN (sc, pointer, list_names, list, args);
+ FFI_ARG_OR_RETURN (sc, pointer, list_pids, list, args);
+ FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ if (sc->vptr->list_length (sc, list_names)
+ != sc->vptr->list_length (sc, list_pids))
+ return
+ sc->vptr->mk_string (sc, "length of first two arguments must match");
+
+ err = ffi_list2argv (sc, list_names, &names, &count);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%lu%s element of first argument is "
+ "neither string nor symbol",
+ (unsigned long) count,
+ ordinal_suffix ((int) count));
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ err = ffi_list2intv (sc, list_pids, (int **) &pids, &count);
+ if (err == gpg_error (GPG_ERR_INV_VALUE))
+ return ffi_sprintf (sc, "%lu%s element of second argument is "
+ "not a number",
+ (unsigned long) count,
+ ordinal_suffix ((int) count));
+ if (err)
+ FFI_RETURN_ERR (sc, err);
+
+ retcodes = xtrycalloc (sizeof *retcodes, count);
+ if (retcodes == NULL)
+ {
+ xfree (names);
+ xfree (pids);
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ }
+
+ err = gnupg_wait_processes ((const char **) names, pids, count, hang,
+ retcodes);
+ if (err == GPG_ERR_GENERAL)
+ err = 0; /* Let the return codes speak. */
+ if (err == GPG_ERR_TIMEOUT)
+ err = 0; /* We may have got some results. */
+
+ for (i = 0; i < count; i++)
+ retcodes_list =
+ (sc->vptr->cons) (sc,
+ sc->vptr->mk_integer (sc,
+ (long) retcodes[count-1-i]),
+ retcodes_list);
+
+ xfree (names);
+ xfree (pids);
+ xfree (retcodes);
+ FFI_RETURN_POINTER (sc, retcodes_list);
+}
+
+
+static pointer
+do_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_pipe (filedes);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+static pointer
+do_inbound_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_inbound_pipe (filedes, NULL, 0);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+static pointer
+do_outbound_pipe (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int filedes[2];
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ err = gnupg_create_outbound_pipe (filedes, NULL, 0);
+#define IMC(A, B) \
+ _cons (sc, sc->vptr->mk_integer (sc, (unsigned long) (A)), (B), 1)
+ FFI_RETURN_POINTER (sc, IMC (filedes[0],
+ IMC (filedes[1], sc->NIL)));
+#undef IMC
+}
+
+
+
+/* Test helper functions. */
+static pointer
+do_file_equal (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ pointer result = sc->F;
+ char *a_name, *b_name;
+ int binary;
+ const char *mode;
+ FILE *a_stream = NULL, *b_stream = NULL;
+ struct stat a_stat, b_stat;
+#define BUFFER_SIZE 1024
+ char a_buf[BUFFER_SIZE], b_buf[BUFFER_SIZE];
+#undef BUFFER_SIZE
+ size_t chunk;
+
+ FFI_ARG_OR_RETURN (sc, char *, a_name, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, b_name, string, args);
+ FFI_ARG_OR_RETURN (sc, int, binary, bool, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ mode = binary ? "rb" : "r";
+ a_stream = fopen (a_name, mode);
+ if (a_stream == NULL)
+ goto errout;
+
+ b_stream = fopen (b_name, mode);
+ if (b_stream == NULL)
+ goto errout;
+
+ if (fstat (fileno (a_stream), &a_stat) < 0)
+ goto errout;
+
+ if (fstat (fileno (b_stream), &b_stat) < 0)
+ goto errout;
+
+ if (binary && a_stat.st_size != b_stat.st_size)
+ {
+ if (verbose)
+ fprintf (stderr, "Files %s and %s differ in size %lu != %lu\n",
+ a_name, b_name, (unsigned long) a_stat.st_size,
+ (unsigned long) b_stat.st_size);
+
+ goto out;
+ }
+
+ while (! feof (a_stream))
+ {
+ chunk = sizeof a_buf;
+
+ chunk = fread (a_buf, 1, chunk, a_stream);
+ if (chunk == 0 && ferror (a_stream))
+ goto errout; /* some error */
+
+ if (fread (b_buf, 1, chunk, b_stream) < chunk)
+ {
+ if (feof (b_stream))
+ goto out; /* short read */
+ goto errout; /* some error */
+ }
+
+ if (chunk > 0 && memcmp (a_buf, b_buf, chunk) != 0)
+ goto out;
+ }
+
+ fread (b_buf, 1, 1, b_stream);
+ if (! feof (b_stream))
+ goto out; /* b is longer */
+
+ /* They match. */
+ result = sc->T;
+
+ out:
+ if (a_stream)
+ fclose (a_stream);
+ if (b_stream)
+ fclose (b_stream);
+ FFI_RETURN_POINTER (sc, result);
+ errout:
+ err = gpg_error_from_syserror ();
+ goto out;
+}
+
+static pointer
+do_splice (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int source;
+ char buffer[1024];
+ ssize_t bytes_read;
+ pointer sinks, sink;
+ FFI_ARG_OR_RETURN (sc, int, source, number, args);
+ sinks = args;
+ if (sinks == sc->NIL)
+ return ffi_sprintf (sc, "need at least one sink");
+ for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink), ffi_arg_index++)
+ if (! sc->vptr->is_number (pair_car (sink)))
+ return ffi_sprintf (sc, "%d%s argument is not a number",
+ ffi_arg_index, ordinal_suffix (ffi_arg_index));
+
+ while (1)
+ {
+ bytes_read = read (source, buffer, sizeof buffer);
+ if (bytes_read == 0)
+ break;
+ if (bytes_read < 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+
+ for (sink = sinks; sink != sc->NIL; sink = pair_cdr (sink))
+ {
+ int fd = sc->vptr->ivalue (pair_car (sink));
+ char *p = buffer;
+ ssize_t left = bytes_read;
+
+ while (left)
+ {
+ ssize_t written = write (fd, p, left);
+ if (written < 0)
+ FFI_RETURN_ERR (sc, gpg_error_from_syserror ());
+ assert (written <= left);
+ left -= written;
+ p += written;
+ }
+ }
+ }
+ FFI_RETURN (sc);
+}
+
+static pointer
+do_string_index (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_rindex (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char needle;
+ ssize_t offset = 0;
+ char *position;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char, needle, character, args);
+ if (args != sc->NIL)
+ {
+ FFI_ARG_OR_RETURN (sc, ssize_t, offset, number, args);
+ if (offset < 0)
+ return ffi_sprintf (sc, "offset must be positive");
+ if (offset > strlen (haystack))
+ return ffi_sprintf (sc, "offset exceeds haystack");
+ }
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ position = strrchr (haystack+offset, needle);
+ if (position)
+ FFI_RETURN_INT (sc, position - haystack);
+ else
+ FFI_RETURN_POINTER (sc, sc->F);
+}
+
+static pointer
+do_string_contains (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ char *haystack;
+ char *needle;
+ FFI_ARG_OR_RETURN (sc, char *, haystack, string, args);
+ FFI_ARG_OR_RETURN (sc, char *, needle, string, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_POINTER (sc, strstr (haystack, needle) ? sc->T : sc->F);
+}
+
+
+
+static pointer
+do_get_verbose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+ FFI_RETURN_INT (sc, verbose);
+}
+
+static pointer
+do_set_verbose (scheme *sc, pointer args)
+{
+ FFI_PROLOG ();
+ int new_verbosity, old;
+ FFI_ARG_OR_RETURN (sc, int, new_verbosity, number, args);
+ FFI_ARGS_DONE_OR_RETURN (sc, args);
+
+ old = verbose;
+ verbose = new_verbosity;
+
+ FFI_RETURN_INT (sc, old);
+}
+
+
+gpg_error_t
+ffi_list2argv (scheme *sc, pointer list, char ***argv, size_t *len)
+{
+ int i;
+
+ *len = sc->vptr->list_length (sc, list);
+ *argv = xtrycalloc (*len + 1, sizeof **argv);
+ if (*argv == NULL)
+ return gpg_error_from_syserror ();
+
+ for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
+ {
+ if (sc->vptr->is_string (sc->vptr->pair_car (list)))
+ (*argv)[i++] = sc->vptr->string_value (sc->vptr->pair_car (list));
+ else if (sc->vptr->is_symbol (sc->vptr->pair_car (list)))
+ (*argv)[i++] = sc->vptr->symname (sc->vptr->pair_car (list));
+ else
+ {
+ xfree (*argv);
+ *argv = NULL;
+ *len = i;
+ return gpg_error (GPG_ERR_INV_VALUE);
+ }
+ }
+ (*argv)[i] = NULL;
+ return 0;
+}
+
+gpg_error_t
+ffi_list2intv (scheme *sc, pointer list, int **intv, size_t *len)
+{
+ int i;
+
+ *len = sc->vptr->list_length (sc, list);
+ *intv = xtrycalloc (*len, sizeof **intv);
+ if (*intv == NULL)
+ return gpg_error_from_syserror ();
+
+ for (i = 0; sc->vptr->is_pair (list); list = sc->vptr->pair_cdr (list))
+ {
+ if (sc->vptr->is_number (sc->vptr->pair_car (list)))
+ (*intv)[i++] = sc->vptr->ivalue (sc->vptr->pair_car (list));
+ else
+ {
+ xfree (*intv);
+ *intv = NULL;
+ *len = i;
+ return gpg_error (GPG_ERR_INV_VALUE);
+ }
+ }
+
+ return 0;
+}
+
+
+char *
+ffi_schemify_name (const char *s, int macro)
+{
+ /* Fixme: We should use xtrystrdup and return NULL. However, this
+ * requires a lot more changes. Simply returning S as done
+ * originally is not an option. */
+ char *n = xstrdup (s), *p;
+ /* if (n == NULL) */
+ /* return s; */
+
+ for (p = n; *p; p++)
+ {
+ *p = (char) tolower (*p);
+ /* We convert _ to - in identifiers. We allow, however, for
+ function names to start with a leading _. The functions in
+ this namespace are not yet finalized and might change or
+ vanish without warning. Use them with care. */
+ if (! macro
+ && p != n
+ && *p == '_')
+ *p = '-';
+ }
+ return n;
+}
+
+pointer
+ffi_sprintf (scheme *sc, const char *format, ...)
+{
+ pointer result;
+ va_list listp;
+ char *expression;
+ int size, written;
+
+ va_start (listp, format);
+ size = vsnprintf (NULL, 0, format, listp);
+ va_end (listp);
+
+ expression = xtrymalloc (size + 1);
+ if (expression == NULL)
+ return NULL;
+
+ va_start (listp, format);
+ written = vsnprintf (expression, size + 1, format, listp);
+ va_end (listp);
+
+ assert (size == written);
+
+ result = sc->vptr->mk_string (sc, expression);
+ xfree (expression);
+ return result;
+}
+
+void
+ffi_scheme_eval (scheme *sc, const char *format, ...)
+{
+ va_list listp;
+ char *expression;
+ int size, written;
+
+ va_start (listp, format);
+ size = vsnprintf (NULL, 0, format, listp);
+ va_end (listp);
+
+ expression = xtrymalloc (size + 1);
+ if (expression == NULL)
+ return;
+
+ va_start (listp, format);
+ written = vsnprintf (expression, size + 1, format, listp);
+ va_end (listp);
+
+ assert (size == written);
+
+ sc->vptr->load_string (sc, expression);
+ xfree (expression);
+}
+
+gpg_error_t
+ffi_init (scheme *sc, const char *argv0, const char *scriptname,
+ int argc, const char **argv)
+{
+ int i;
+ pointer args = sc->NIL;
+
+ /* bitwise arithmetic */
+ ffi_define_function (sc, logand);
+ ffi_define_function (sc, logior);
+ ffi_define_function (sc, logxor);
+ ffi_define_function (sc, lognot);
+
+ /* libc. */
+ ffi_define_constant (sc, O_RDONLY);
+ ffi_define_constant (sc, O_WRONLY);
+ ffi_define_constant (sc, O_RDWR);
+ ffi_define_constant (sc, O_CREAT);
+ ffi_define_constant (sc, O_APPEND);
+#ifndef O_BINARY
+# define O_BINARY 0
+#endif
+#ifndef O_TEXT
+# define O_TEXT 0
+#endif
+ ffi_define_constant (sc, O_BINARY);
+ ffi_define_constant (sc, O_TEXT);
+ ffi_define_constant (sc, STDIN_FILENO);
+ ffi_define_constant (sc, STDOUT_FILENO);
+ ffi_define_constant (sc, STDERR_FILENO);
+ ffi_define_constant (sc, SEEK_SET);
+ ffi_define_constant (sc, SEEK_CUR);
+ ffi_define_constant (sc, SEEK_END);
+
+ ffi_define_function (sc, sleep);
+ ffi_define_function (sc, usleep);
+ ffi_define_function (sc, chdir);
+ ffi_define_function (sc, strerror);
+ ffi_define_function (sc, getenv);
+ ffi_define_function (sc, setenv);
+ ffi_define_function_name (sc, "_exit", exit);
+ ffi_define_function (sc, open);
+ ffi_define_function (sc, fdopen);
+ ffi_define_function (sc, close);
+ ffi_define_function (sc, seek);
+ ffi_define_function (sc, get_temp_path);
+ ffi_define_function_name (sc, "_mkdtemp", mkdtemp);
+ ffi_define_function (sc, unlink);
+ ffi_define_function (sc, unlink_recursively);
+ ffi_define_function (sc, rename);
+ ffi_define_function (sc, getcwd);
+ ffi_define_function (sc, mkdir);
+ ffi_define_function (sc, rmdir);
+ ffi_define_function (sc, get_isotime);
+ ffi_define_function (sc, get_time);
+ ffi_define_function (sc, getpid);
+
+ /* Random numbers. */
+ ffi_define_function (sc, srandom);
+ ffi_define_function (sc, random);
+ ffi_define_function (sc, make_random_string);
+
+ /* Process management. */
+ ffi_define_function (sc, spawn_process);
+ ffi_define_function (sc, spawn_process_fd);
+ ffi_define_function (sc, wait_process);
+ ffi_define_function (sc, wait_processes);
+ ffi_define_function (sc, pipe);
+ ffi_define_function (sc, inbound_pipe);
+ ffi_define_function (sc, outbound_pipe);
+
+ /* estream functions. */
+ ffi_define_function_name (sc, "es-fclose", es_fclose);
+ ffi_define_function_name (sc, "es-read", es_read);
+ ffi_define_function_name (sc, "es-feof", es_feof);
+ ffi_define_function_name (sc, "es-write", es_write);
+
+ /* Test helper functions. */
+ ffi_define_function (sc, file_equal);
+ ffi_define_function (sc, splice);
+ ffi_define_function (sc, string_index);
+ ffi_define_function (sc, string_rindex);
+ ffi_define_function_name (sc, "string-contains?", string_contains);
+
+ /* User interface. */
+ ffi_define_function (sc, flush_stdio);
+ ffi_define_function (sc, prompt);
+
+ /* Configuration. */
+ ffi_define_function_name (sc, "*verbose*", get_verbose);
+ ffi_define_function_name (sc, "*set-verbose!*", set_verbose);
+
+ ffi_define (sc, "*argv0*", sc->vptr->mk_string (sc, argv0));
+ ffi_define (sc, "*scriptname*", sc->vptr->mk_string (sc, scriptname));
+ for (i = argc - 1; i >= 0; i--)
+ {
+ pointer value = sc->vptr->mk_string (sc, argv[i]);
+ args = (sc->vptr->cons) (sc, value, args);
+ }
+ ffi_define (sc, "*args*", args);
+
+#if _WIN32
+ ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ';'));
+#else
+ ffi_define (sc, "*pathsep*", sc->vptr->mk_character (sc, ':'));
+#endif
+
+ ffi_define (sc, "*win32*",
+#if _WIN32
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+ ffi_define (sc, "*maintainer-mode*",
+#if MAINTAINER_MODE
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+ ffi_define (sc, "*run-all-tests*",
+#if RUN_ALL_TESTS
+ sc->T
+#else
+ sc->F
+#endif
+ );
+
+
+ ffi_define (sc, "*stdin*",
+ sc->vptr->mk_port_from_file (sc, stdin, port_input));
+ ffi_define (sc, "*stdout*",
+ sc->vptr->mk_port_from_file (sc, stdout, port_output));
+ ffi_define (sc, "*stderr*",
+ sc->vptr->mk_port_from_file (sc, stderr, port_output));
+
+ return 0;
+}
diff --git a/tests/gpgscm/ffi.h b/tests/gpgscm/ffi.h
new file mode 100644
index 0000000..eba6282
--- /dev/null
+++ b/tests/gpgscm/ffi.h
@@ -0,0 +1,30 @@
+/* FFI interface for TinySCHEME.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef GPGSCM_FFI_H
+#define GPGSCM_FFI_H
+
+#include <gpg-error.h>
+#include "scheme.h"
+
+gpg_error_t ffi_init (scheme *sc, const char *argv0, const char *scriptname,
+ int argc, const char **argv);
+
+#endif /* GPGSCM_FFI_H */
diff --git a/tests/gpgscm/ffi.scm b/tests/gpgscm/ffi.scm
new file mode 100644
index 0000000..051c2c2
--- /dev/null
+++ b/tests/gpgscm/ffi.scm
@@ -0,0 +1,51 @@
+;; FFI interface for TinySCHEME.
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+;; Foreign function wrapper. Expects F to return a list with the
+;; first element being the `error_t' value returned by the foreign
+;; function. The error is thrown, or the cdr of the result is
+;; returned.
+(define (ffi-apply name f args)
+ (let ((result (apply f args)))
+ (cond
+ ((string? result)
+ (ffi-fail name args result))
+ ((not (= (car result) 0))
+ (ffi-fail name args (strerror (car result))))
+ ((and (= (car result) 0) (pair? (cdr result))) (cadr result))
+ ((= (car result) 0) '())
+ (else
+ (throw (list "Result violates FFI calling convention: " result))))))
+
+(define (ffi-fail name args message)
+ (let ((args' (open-output-string)))
+ (write (cons (string->symbol name) args) args')
+ (throw (get-output-string args') message)))
+
+;; Pseudo-definitions for foreign functions. Evaluates to no code,
+;; but serves as documentation.
+(macro (ffi-define form))
+
+;; Runtime support.
+
+;; Low-level mechanism to terminate the process.
+(ffi-define (_exit status))
+
+;; Get the current time in seconds since the epoch.
+(ffi-define (get-time))
diff --git a/tests/gpgscm/gnupg.scm b/tests/gpgscm/gnupg.scm
new file mode 100644
index 0000000..77bf479
--- /dev/null
+++ b/tests/gpgscm/gnupg.scm
@@ -0,0 +1,49 @@
+;; Common definitions for executing gpg and related tools.
+;;
+;; Copyright (C) 2016, 2017 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+;; Evaluate a sequence of expressions with the given home directory.
+(define-macro (with-home-directory gnupghome . expressions)
+ (let ((original-home-directory (gensym)))
+ `(let ((,original-home-directory (getenv "GNUPGHOME")))
+ (dynamic-wind
+ (lambda () (setenv "GNUPGHOME" ,gnupghome #t))
+ (lambda () ,@expressions)
+ (lambda () (setenv "GNUPGHOME" ,original-home-directory #t))))))
+
+;; Evaluate a sequence of expressions with an ephemeral home
+;; directory.
+(define-macro (with-ephemeral-home-directory setup-fn teardown-fn . expressions)
+ (let ((original-home-directory (gensym))
+ (ephemeral-home-directory (gensym))
+ (setup (gensym))
+ (teardown (gensym)))
+ `(let ((,original-home-directory (getenv "GNUPGHOME"))
+ (,ephemeral-home-directory (mkdtemp))
+ (,setup (delay (,setup-fn)))
+ (,teardown (delay (,teardown-fn))))
+ (finally (unlink-recursively ,ephemeral-home-directory)
+ (dynamic-wind
+ (lambda ()
+ (setenv "GNUPGHOME" ,ephemeral-home-directory #t)
+ (with-working-directory ,ephemeral-home-directory (force ,setup)))
+ (lambda () ,@expressions)
+ (lambda ()
+ (setenv "GNUPGHOME" ,ephemeral-home-directory #t)
+ (with-working-directory ,ephemeral-home-directory (force ,teardown))
+ (setenv "GNUPGHOME" ,original-home-directory #t)))))))
diff --git a/tests/gpgscm/init.scm b/tests/gpgscm/init.scm
new file mode 100644
index 0000000..66bec0f
--- /dev/null
+++ b/tests/gpgscm/init.scm
@@ -0,0 +1,823 @@
+; Initialization file for TinySCHEME 1.41
+
+; Per R5RS, up to four deep compositions should be defined
+(define (caar x) (car (car x)))
+(define (cadr x) (car (cdr x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (car (cdr x))))
+(define (cadar x) (car (cdr (car x))))
+(define (caddr x) (car (cdr (cdr x))))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (car (cdr x))))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (car (cdr x)))))
+(define (caadar x) (car (car (cdr (car x)))))
+(define (caaddr x) (car (car (cdr (cdr x)))))
+(define (cadaar x) (car (cdr (car (car x)))))
+(define (cadadr x) (car (cdr (car (cdr x)))))
+(define (caddar x) (car (cdr (cdr (car x)))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (car (cdr x)))))
+(define (cdadar x) (cdr (car (cdr (car x)))))
+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (car (cdr x)))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+;;;; Utility to ease macro creation
+(define (macro-expand form)
+ ((eval (get-closure-code (eval (car form)))) form))
+
+(define (macro-expand-all form)
+ (if (macro? form)
+ (macro-expand-all (macro-expand form))
+ form))
+
+(define *compile-hook* macro-expand-all)
+
+
+(macro (unless form)
+ `(if (not ,(cadr form)) (begin ,@(cddr form))))
+
+(macro (when form)
+ `(if ,(cadr form) (begin ,@(cddr form))))
+
+; DEFINE-MACRO Contributed by Andy Gaynor
+(macro (define-macro dform)
+ (if (symbol? (cadr dform))
+ `(macro ,@(cdr dform))
+ (let ((form (gensym)))
+ `(macro (,(caadr dform) ,form)
+ (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
+
+; Utilities for math. Notice that inexact->exact is primitive,
+; but exact->inexact is not.
+(define exact? integer?)
+(define (inexact? x) (and (real? x) (not (integer? x))))
+(define (even? n) (= (remainder n 2) 0))
+(define (odd? n) (not (= (remainder n 2) 0)))
+(define (zero? n) (= n 0))
+(define (positive? n) (> n 0))
+(define (negative? n) (< n 0))
+(define complex? number?)
+(define rational? real?)
+(define (abs n) (if (>= n 0) n (- n)))
+(define (exact->inexact n) (* n 1.0))
+(define (<> n1 n2) (not (= n1 n2)))
+
+; min and max must return inexact if any arg is inexact; use (+ n 0.0)
+(define (max . lst)
+ (foldr (lambda (a b)
+ (if (> a b)
+ (if (exact? b) a (+ a 0.0))
+ (if (exact? a) b (+ b 0.0))))
+ (car lst) (cdr lst)))
+(define (min . lst)
+ (foldr (lambda (a b)
+ (if (< a b)
+ (if (exact? b) a (+ a 0.0))
+ (if (exact? a) b (+ b 0.0))))
+ (car lst) (cdr lst)))
+
+(define (succ x) (+ x 1))
+(define (pred x) (- x 1))
+(define gcd
+ (lambda a
+ (if (null? a)
+ 0
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (= bb 0)
+ aa
+ (gcd bb (remainder aa bb)))))))
+(define lcm
+ (lambda a
+ (if (null? a)
+ 1
+ (let ((aa (abs (car a)))
+ (bb (abs (cadr a))))
+ (if (or (= aa 0) (= bb 0))
+ 0
+ (abs (* (quotient aa (gcd aa bb)) bb)))))))
+
+
+(define (string . charlist)
+ (list->string charlist))
+
+(define (list->string charlist)
+ (let* ((len (length charlist))
+ (newstr (make-string len))
+ (fill-string!
+ (lambda (str i len charlist)
+ (if (= i len)
+ str
+ (begin (string-set! str i (car charlist))
+ (fill-string! str (+ i 1) len (cdr charlist)))))))
+ (fill-string! newstr 0 len charlist)))
+
+(define (string-fill! s e)
+ (let ((n (string-length s)))
+ (let loop ((i 0))
+ (if (= i n)
+ s
+ (begin (string-set! s i e) (loop (succ i)))))))
+
+(define (string->list s)
+ (let loop ((n (pred (string-length s))) (l '()))
+ (if (= n -1)
+ l
+ (loop (pred n) (cons (string-ref s n) l)))))
+
+(define (string-copy str)
+ (string-append str))
+
+(define (string->anyatom str pred)
+ (let* ((a (string->atom str)))
+ (if (pred a) a
+ (error "string->xxx: not a xxx" a))))
+
+(define (string->number str . base)
+ (let ((n (string->atom str (if (null? base) 10 (car base)))))
+ (if (number? n) n #f)))
+
+(define (anyatom->string n pred)
+ (if (pred n)
+ (atom->string n)
+ (error "xxx->string: not a xxx" n)))
+
+(define (number->string n . base)
+ (atom->string n (if (null? base) 10 (car base))))
+
+
+(define (char-cmp? cmp a b)
+ (cmp (char->integer a) (char->integer b)))
+(define (char-ci-cmp? cmp a b)
+ (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
+
+(define (char=? a b) (char-cmp? = a b))
+(define (char<? a b) (char-cmp? < a b))
+(define (char>? a b) (char-cmp? > a b))
+(define (char<=? a b) (char-cmp? <= a b))
+(define (char>=? a b) (char-cmp? >= a b))
+
+(define (char-ci=? a b) (char-ci-cmp? = a b))
+(define (char-ci<? a b) (char-ci-cmp? < a b))
+(define (char-ci>? a b) (char-ci-cmp? > a b))
+(define (char-ci<=? a b) (char-ci-cmp? <= a b))
+(define (char-ci>=? a b) (char-ci-cmp? >= a b))
+
+; Note the trick of returning (cmp x y)
+(define (string-cmp? chcmp cmp a b)
+ (let ((na (string-length a)) (nb (string-length b)))
+ (let loop ((i 0))
+ (cond
+ ((= i na)
+ (if (= i nb) (cmp 0 0) (cmp 0 1)))
+ ((= i nb)
+ (cmp 1 0))
+ ((chcmp = (string-ref a i) (string-ref b i))
+ (loop (succ i)))
+ (else
+ (chcmp cmp (string-ref a i) (string-ref b i)))))))
+
+
+(define (string=? a b) (string-cmp? char-cmp? = a b))
+(define (string<? a b) (string-cmp? char-cmp? < a b))
+(define (string>? a b) (string-cmp? char-cmp? > a b))
+(define (string<=? a b) (string-cmp? char-cmp? <= a b))
+(define (string>=? a b) (string-cmp? char-cmp? >= a b))
+
+(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
+(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
+(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
+(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
+(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
+
+(define (list . x) x)
+
+(define (foldr f x lst)
+ (if (null? lst)
+ x
+ (foldr f (f x (car lst)) (cdr lst))))
+
+(define (unzip1-with-cdr . lists)
+ (unzip1-with-cdr-iterative lists '() '()))
+
+(define (unzip1-with-cdr-iterative lists cars cdrs)
+ (if (null? lists)
+ (cons cars cdrs)
+ (let ((car1 (caar lists))
+ (cdr1 (cdar lists)))
+ (unzip1-with-cdr-iterative
+ (cdr lists)
+ (append cars (list car1))
+ (append cdrs (list cdr1))))))
+
+(define (map proc . lists)
+ (if (null? lists)
+ (apply proc)
+ (if (null? (car lists))
+ '()
+ (let* ((unz (apply unzip1-with-cdr lists))
+ (cars (car unz))
+ (cdrs (cdr unz)))
+ (cons (apply proc cars) (apply map (cons proc cdrs)))))))
+
+(define (for-each proc . lists)
+ (if (null? lists)
+ (apply proc)
+ (if (null? (car lists))
+ #t
+ (let* ((unz (apply unzip1-with-cdr lists))
+ (cars (car unz))
+ (cdrs (cdr unz)))
+ (apply proc cars) (apply map (cons proc cdrs))))))
+
+(define (list-tail x k)
+ (if (zero? k)
+ x
+ (list-tail (cdr x) (- k 1))))
+
+(define (list-ref x k)
+ (car (list-tail x k)))
+
+(define (last-pair x)
+ (if (pair? (cdr x))
+ (last-pair (cdr x))
+ x))
+
+(define (head stream) (car stream))
+
+(define (tail stream) (force (cdr stream)))
+
+(define (vector-equal? x y)
+ (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
+ (let ((n (vector-length x)))
+ (let loop ((i 0))
+ (if (= i n)
+ #t
+ (and (equal? (vector-ref x i) (vector-ref y i))
+ (loop (succ i))))))))
+
+(define (list->vector x)
+ (apply vector x))
+
+(define (vector-fill! v e)
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (if (= i n)
+ v
+ (begin (vector-set! v i e) (loop (succ i)))))))
+
+(define (vector->list v)
+ (let loop ((n (pred (vector-length v))) (l '()))
+ (if (= n -1)
+ l
+ (loop (pred n) (cons (vector-ref v n) l)))))
+
+;; The following quasiquote macro is due to Eric S. Tiedemann.
+;; Copyright 1988 by Eric S. Tiedemann; all rights reserved.
+;;
+;; Subsequently modified to handle vectors: D. Souflis
+
+(macro
+ quasiquote
+ (lambda (l)
+ (define (mcons f l r)
+ (if (and (pair? r)
+ (eq? (car r) 'quote)
+ (eq? (car (cdr r)) (cdr f))
+ (pair? l)
+ (eq? (car l) 'quote)
+ (eq? (car (cdr l)) (car f)))
+ (if (or (procedure? f) (number? f) (string? f))
+ f
+ (list 'quote f))
+ (if (eqv? l vector)
+ (apply l (eval r))
+ (list 'cons l r)
+ )))
+ (define (mappend f l r)
+ (if (or (null? (cdr f))
+ (and (pair? r)
+ (eq? (car r) 'quote)
+ (eq? (car (cdr r)) '())))
+ l
+ (list 'append l r)))
+ (define (foo level form)
+ (cond ((not (pair? form))
+ (if (or (procedure? form) (number? form) (string? form))
+ form
+ (list 'quote form))
+ )
+ ((eq? 'quasiquote (car form))
+ (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
+ (#t (if (zero? level)
+ (cond ((eq? (car form) 'unquote) (car (cdr form)))
+ ((eq? (car form) 'unquote-splicing)
+ (error "Unquote-splicing wasn't in a list:"
+ form))
+ ((and (pair? (car form))
+ (eq? (car (car form)) 'unquote-splicing))
+ (mappend form (car (cdr (car form)))
+ (foo level (cdr form))))
+ (#t (mcons form (foo level (car form))
+ (foo level (cdr form)))))
+ (cond ((eq? (car form) 'unquote)
+ (mcons form ''unquote (foo (- level 1)
+ (cdr form))))
+ ((eq? (car form) 'unquote-splicing)
+ (mcons form ''unquote-splicing
+ (foo (- level 1) (cdr form))))
+ (#t (mcons form (foo level (car form))
+ (foo level (cdr form)))))))))
+ (foo 0 (car (cdr l)))))
+
+;;;;;Helper for the dynamic-wind definition. By Tom Breton (Tehom)
+(define (shared-tail x y)
+ (let ((len-x (length x))
+ (len-y (length y)))
+ (define (shared-tail-helper x y)
+ (if
+ (eq? x y)
+ x
+ (shared-tail-helper (cdr x) (cdr y))))
+
+ (cond
+ ((> len-x len-y)
+ (shared-tail-helper
+ (list-tail x (- len-x len-y))
+ y))
+ ((< len-x len-y)
+ (shared-tail-helper
+ x
+ (list-tail y (- len-y len-x))))
+ (#t (shared-tail-helper x y)))))
+
+;;;;;Dynamic-wind by Tom Breton (Tehom)
+
+;;Guarded because we must only eval this once, because doing so
+;;redefines call/cc in terms of old call/cc
+(unless (defined? 'dynamic-wind)
+ (let
+ ;;These functions are defined in the context of a private list of
+ ;;pairs of before/after procs.
+ ( (*active-windings* '())
+ ;;We'll define some functions into the larger environment, so
+ ;;we need to know it.
+ (outer-env (current-environment)))
+
+ ;;Poor-man's structure operations
+ (define before-func car)
+ (define after-func cdr)
+ (define make-winding cons)
+
+ ;;Manage active windings
+ (define (activate-winding! new)
+ ((before-func new))
+ (set! *active-windings* (cons new *active-windings*)))
+ (define (deactivate-top-winding!)
+ (let ((old-top (car *active-windings*)))
+ ;;Remove it from the list first so it's not active during its
+ ;;own exit.
+ (set! *active-windings* (cdr *active-windings*))
+ ((after-func old-top))))
+
+ (define (set-active-windings! new-ws)
+ (unless (eq? new-ws *active-windings*)
+ (let ((shared (shared-tail new-ws *active-windings*)))
+
+ ;;Define the looping functions.
+ ;;Exit the old list. Do deeper ones last. Don't do
+ ;;any shared ones.
+ (define (pop-many)
+ (unless (eq? *active-windings* shared)
+ (deactivate-top-winding!)
+ (pop-many)))
+ ;;Enter the new list. Do deeper ones first so that the
+ ;;deeper windings will already be active. Don't do any
+ ;;shared ones.
+ (define (push-many new-ws)
+ (unless (eq? new-ws shared)
+ (push-many (cdr new-ws))
+ (activate-winding! (car new-ws))))
+
+ ;;Do it.
+ (pop-many)
+ (push-many new-ws))))
+
+ ;;The definitions themselves.
+ (eval
+ `(define call-with-current-continuation
+ ;;It internally uses the built-in call/cc, so capture it.
+ ,(let ((old-c/cc call-with-current-continuation))
+ (lambda (func)
+ ;;Use old call/cc to get the continuation.
+ (old-c/cc
+ (lambda (continuation)
+ ;;Call func with not the continuation itself
+ ;;but a procedure that adjusts the active
+ ;;windings to what they were when we made
+ ;;this, and only then calls the
+ ;;continuation.
+ (func
+ (let ((current-ws *active-windings*))
+ (lambda (x)
+ (set-active-windings! current-ws)
+ (continuation x)))))))))
+ outer-env)
+ ;;We can't just say "define (dynamic-wind before thunk after)"
+ ;;because the lambda it's defined to lives in this environment,
+ ;;not in the global environment.
+ (eval
+ `(define dynamic-wind
+ ,(lambda (before thunk after)
+ ;;Make a new winding
+ (activate-winding! (make-winding before after))
+ (let ((result (thunk)))
+ ;;Get rid of the new winding.
+ (deactivate-top-winding!)
+ ;;The return value is that of thunk.
+ result)))
+ outer-env)))
+
+(define call/cc call-with-current-continuation)
+
+
+;;;;; atom? and equal? written by a.k
+
+;;;; atom?
+(define (atom? x)
+ (not (pair? x)))
+
+;;;; equal?
+(define (equal? x y)
+ (cond
+ ((pair? x)
+ (and (pair? y)
+ (equal? (car x) (car y))
+ (equal? (cdr x) (cdr y))))
+ ((vector? x)
+ (and (vector? y) (vector-equal? x y)))
+ ((string? x)
+ (and (string? y) (string=? x y)))
+ (else (eqv? x y))))
+
+;;;; (do ((var init inc) ...) (endtest result ...) body ...)
+;;
+(macro do
+ (lambda (do-macro)
+ (apply (lambda (do vars endtest . body)
+ (let ((do-loop (gensym)))
+ `(letrec ((,do-loop
+ (lambda ,(map (lambda (x)
+ (if (pair? x) (car x) x))
+ `,vars)
+ (if ,(car endtest)
+ (begin ,@(cdr endtest))
+ (begin
+ ,@body
+ (,do-loop
+ ,@(map (lambda (x)
+ (cond
+ ((not (pair? x)) x)
+ ((< (length x) 3) (car x))
+ (else (car (cdr (cdr x))))))
+ `,vars)))))))
+ (,do-loop
+ ,@(map (lambda (x)
+ (if (and (pair? x) (cdr x))
+ (car (cdr x))
+ '()))
+ `,vars)))))
+ do-macro)))
+
+;;;; generic-member
+(define (generic-member cmp obj lst)
+ (cond
+ ((null? lst) #f)
+ ((cmp obj (car lst)) lst)
+ (else (generic-member cmp obj (cdr lst)))))
+
+(define (memq obj lst)
+ (generic-member eq? obj lst))
+(define (memv obj lst)
+ (generic-member eqv? obj lst))
+(define (member obj lst)
+ (generic-member equal? obj lst))
+
+;;;; generic-assoc
+(define (generic-assoc cmp obj alst)
+ (cond
+ ((null? alst) #f)
+ ((cmp obj (caar alst)) (car alst))
+ (else (generic-assoc cmp obj (cdr alst)))))
+
+(define (assq obj alst)
+ (generic-assoc eq? obj alst))
+(define (assv obj alst)
+ (generic-assoc eqv? obj alst))
+(define (assoc obj alst)
+ (generic-assoc equal? obj alst))
+
+(define (acons x y z) (cons (cons x y) z))
+
+;;;; Handy for imperative programs
+;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
+(macro (define-with-return form)
+ `(define ,(cadr form)
+ (call/cc (lambda (return) ,@(cddr form)))))
+
+;; Print the given history.
+(define (vm-history-print history)
+ (let loop ((n 0) (skip 0) (frames history))
+ (cond
+ ((null? frames)
+ #t)
+ ((> skip 0)
+ (loop 0 (- skip 1) (cdr frames)))
+ (else
+ (let ((f (car frames)))
+ (display n)
+ (display ": ")
+ (let ((tag (get-tag f)))
+ (when (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
+ (display (basename (car tag)))
+ (display ":")
+ (display (+ 1 (cdr tag)))
+ (display ": ")))
+ (write f))
+ (newline)
+ (loop (+ n 1) skip (cdr frames))))))
+
+;;;; Simple exception handling
+;
+; Exceptions are caught as follows:
+;
+; (catch (do-something to-recover and-return meaningful-value)
+; (if-something goes-wrong)
+; (with-these calls))
+;
+; "Catch" establishes a scope spanning multiple call-frames until
+; another "catch" is encountered. Within the recovery expression
+; the thrown exception is bound to *error*. Errors can be rethrown
+; using (rethrow *error*).
+;
+; Finalization can be expressed using "finally":
+;
+; (finally (finalize-something called-purely-for side-effects)
+; (whether-or-not something goes-wrong)
+; (with-these calls))
+;
+; The final expression is executed purely for its side-effects,
+; both when the function exits successfully, and when an exception
+; is thrown.
+;
+; Exceptions are thrown with:
+;
+; (throw "message")
+;
+; If used outside a (catch ...), reverts to (error "message")
+
+(define *handlers* (list))
+
+(define (push-handler proc)
+ (set! *handlers* (cons proc *handlers*)))
+
+(define (pop-handler)
+ (let ((h (car *handlers*)))
+ (set! *handlers* (cdr *handlers*))
+ h))
+
+(define (more-handlers?)
+ (pair? *handlers*))
+
+;; This throws an exception.
+(define (throw message . args)
+ (throw' message args (cdr (*vm-history*))))
+
+;; This is used by the vm to throw exceptions.
+(define (throw' message args history)
+ (cond
+ ((and args (list? args) (= 2 (length args))
+ (equal? *interpreter-exit* (car args)))
+ (*run-atexit-handlers*)
+ (quit (cadr args)))
+ ((more-handlers?)
+ ((pop-handler) message args history))
+ (else
+ (display message)
+ (when (and args (not (null? args)))
+ (display ": ")
+ (if (and (pair? args) (string? (car args)))
+ (begin (display (car args))
+ (unless (null? (cdr args))
+ (newline)
+ (write (cdr args))))
+ (write args)))
+ (newline)
+ (vm-history-print history)
+ (quit 1))))
+
+;; Convenience function to rethrow the error.
+(define (rethrow e)
+ (apply throw' e))
+
+(macro (catch form)
+ (let ((label (gensym)))
+ `(call/cc (lambda (**exit**)
+ (push-handler (lambda *error* (**exit** ,(cadr form))))
+ (let ((,label (begin ,@(cddr form))))
+ (pop-handler)
+ ,label)))))
+
+(define-macro (finally final-expression . expressions)
+ (let ((result (gensym)))
+ `(let ((,result (catch (begin ,final-expression (rethrow *error*))
+ ,@expressions)))
+ ,final-expression
+ ,result)))
+
+;; Make the vm use throw'.
+(define *error-hook* throw')
+
+
+
+;; High-level mechanism to terminate the process is to throw an error
+;; of the form (*interpreter-exit* status). This gives automatic
+;; resource management a chance to clean up.
+(define *interpreter-exit* (gensym))
+
+;; Terminate the process returning STATUS to the parent.
+(define (exit status)
+ (throw "interpreter exit" *interpreter-exit* status))
+
+;; A list of functions run at interpreter shutdown.
+(define *atexit-handlers* (list))
+
+;; Execute all these functions.
+(define (*run-atexit-handlers*)
+ (unless (null? *atexit-handlers*)
+ (let ((proc (car *atexit-handlers*)))
+ ;; Drop proc from the list so that it will not get
+ ;; executed again even if it raises an exception.
+ (set! *atexit-handlers* (cdr *atexit-handlers*))
+ (proc)
+ (*run-atexit-handlers*))))
+
+;; Register a function to be run at interpreter shutdown.
+(define (atexit proc)
+ (set! *atexit-handlers* (cons proc *atexit-handlers*)))
+
+
+
+;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
+
+(macro (make-environment form)
+ `(apply (lambda ()
+ ,@(cdr form)
+ (current-environment))))
+
+(define-macro (eval-polymorphic x . envl)
+ (display envl)
+ (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
+ (xval (eval x env)))
+ (if (closure? xval)
+ (make-closure (get-closure-code xval) env)
+ xval)))
+
+; Redefine this if you install another package infrastructure
+; Also redefine 'package'
+(define *colon-hook* eval)
+
+(macro (package form)
+ `(apply (lambda ()
+ ,@(cdr form)
+ (current-environment))))
+
+(define-macro (export name . expressions)
+ `(define ,name
+ (begin
+ ,@expressions)))
+
+;;;;; I/O
+
+(define (input-output-port? p)
+ (and (input-port? p) (output-port? p)))
+
+(define (close-port p)
+ (cond
+ ((input-output-port? p) (close-input-port p) (close-output-port p))
+ ((input-port? p) (close-input-port p))
+ ((output-port? p) (close-output-port p))
+ (else (throw "Not a port" p))))
+
+(define (call-with-input-file s p)
+ (let ((inport (open-input-file s)))
+ (if (eq? inport #f)
+ #f
+ (let ((res (p inport)))
+ (close-input-port inport)
+ res))))
+
+(define (call-with-output-file s p)
+ (let ((outport (open-output-file s)))
+ (if (eq? outport #f)
+ #f
+ (let ((res (p outport)))
+ (close-output-port outport)
+ res))))
+
+(define (with-input-from-file s p)
+ (let ((inport (open-input-file s)))
+ (if (eq? inport #f)
+ #f
+ (let ((prev-inport (current-input-port)))
+ (set-input-port inport)
+ (let ((res (p)))
+ (close-input-port inport)
+ (set-input-port prev-inport)
+ res)))))
+
+(define (with-output-to-file s p)
+ (let ((outport (open-output-file s)))
+ (if (eq? outport #f)
+ #f
+ (let ((prev-outport (current-output-port)))
+ (set-output-port outport)
+ (let ((res (p)))
+ (close-output-port outport)
+ (set-output-port prev-outport)
+ res)))))
+
+(define (with-input-output-from-to-files si so p)
+ (let ((inport (open-input-file si))
+ (outport (open-input-file so)))
+ (if (not (and inport outport))
+ (begin
+ (close-input-port inport)
+ (close-output-port outport)
+ #f)
+ (let ((prev-inport (current-input-port))
+ (prev-outport (current-output-port)))
+ (set-input-port inport)
+ (set-output-port outport)
+ (let ((res (p)))
+ (close-input-port inport)
+ (close-output-port outport)
+ (set-input-port prev-inport)
+ (set-output-port prev-outport)
+ res)))))
+
+; Random number generator (maximum cycle)
+(define *seed* 1)
+(define (random-next)
+ (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
+ (set! *seed*
+ (- (* a (- *seed*
+ (* (quotient *seed* q) q)))
+ (* (quotient *seed* q) r)))
+ (if (< *seed* 0) (set! *seed* (+ *seed* m)))
+ *seed*))
+;; SRFI-0
+;; COND-EXPAND
+;; Implemented as a macro
+(define *features* '(srfi-0 tinyscheme))
+
+(define-macro (cond-expand . cond-action-list)
+ (cond-expand-runtime cond-action-list))
+
+(define (cond-expand-runtime cond-action-list)
+ (if (null? cond-action-list)
+ #t
+ (if (cond-eval (caar cond-action-list))
+ `(begin ,@(cdar cond-action-list))
+ (cond-expand-runtime (cdr cond-action-list)))))
+
+(define (cond-eval-and cond-list)
+ (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
+
+(define (cond-eval-or cond-list)
+ (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
+
+(define (cond-eval condition)
+ (cond
+ ((symbol? condition)
+ (if (member condition *features*) #t #f))
+ ((eq? condition #t) #t)
+ ((eq? condition #f) #f)
+ (else (case (car condition)
+ ((and) (cond-eval-and (cdr condition)))
+ ((or) (cond-eval-or (cdr condition)))
+ ((not) (if (not (null? (cddr condition)))
+ (error "cond-expand : 'not' takes 1 argument")
+ (not (cond-eval (cadr condition)))))
+ (else (error "cond-expand : unknown operator" (car condition)))))))
+
+(gc-verbose #f)
diff --git a/tests/gpgscm/lib.scm b/tests/gpgscm/lib.scm
new file mode 100644
index 0000000..258f692
--- /dev/null
+++ b/tests/gpgscm/lib.scm
@@ -0,0 +1,307 @@
+;; Additional library functions for TinySCHEME.
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+(macro (assert form)
+ (let ((tag (get-tag form)))
+ `(if (not ,(cadr form))
+ (throw ,(if (and (pair? tag) (string? (car tag)) (number? (cdr tag)))
+ `(string-append ,(car tag) ":"
+ ,(number->string (+ 1 (cdr tag)))
+ ": Assertion failed: ")
+ "Assertion failed: ")
+ (quote ,(cadr form))))))
+(assert #t)
+(assert (not #f))
+
+;; Trace displays and returns the given value. A debugging aid.
+(define (trace x)
+ (display x)
+ (newline)
+ x)
+
+;; Stringification.
+(define (stringify expression)
+ (let ((p (open-output-string)))
+ (write expression p)
+ (get-output-string p)))
+
+(define (filter pred lst)
+ (cond ((null? lst) '())
+ ((pred (car lst))
+ (cons (car lst) (filter pred (cdr lst))))
+ (else (filter pred (cdr lst)))))
+
+(define (any p l)
+ (cond ((null? l) #f)
+ ((p (car l)) #t)
+ (else (any p (cdr l)))))
+
+(define (all p l)
+ (cond ((null? l) #t)
+ ((not (p (car l))) #f)
+ (else (all p (cdr l)))))
+
+;; Return the first element of a list.
+(define first car)
+
+;; Return the last element of a list.
+(define (last lst)
+ (if (null? (cdr lst))
+ (car lst)
+ (last (cdr lst))))
+
+;; Compute the powerset of a list.
+(define (powerset set)
+ (if (null? set)
+ '(())
+ (let ((rst (powerset (cdr set))))
+ (append (map (lambda (x) (cons (car set) x))
+ rst)
+ rst))))
+
+;; Is PREFIX a prefix of S?
+(define (string-prefix? s prefix)
+ (and (>= (string-length s) (string-length prefix))
+ (string=? prefix (substring s 0 (string-length prefix)))))
+(assert (string-prefix? "Scheme" "Sch"))
+
+;; Is SUFFIX a suffix of S?
+(define (string-suffix? s suffix)
+ (and (>= (string-length s) (string-length suffix))
+ (string=? suffix (substring s (- (string-length s)
+ (string-length suffix))
+ (string-length s)))))
+(assert (string-suffix? "Scheme" "eme"))
+
+;; Locate the first occurrence of needle in haystack starting at offset.
+(ffi-define (string-index haystack needle [offset]))
+(assert (= 2 (string-index "Hallo" #\l)))
+(assert (= 3 (string-index "Hallo" #\l 3)))
+(assert (equal? #f (string-index "Hallo" #\.)))
+
+;; Locate the last occurrence of needle in haystack starting at offset.
+(ffi-define (string-rindex haystack needle [offset]))
+(assert (= 3 (string-rindex "Hallo" #\l)))
+(assert (equal? #f (string-rindex "Hallo" #\a 2)))
+(assert (equal? #f (string-rindex "Hallo" #\.)))
+
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-split-pln haystack predicate lookahead n)
+ (let ((length (string-length haystack)))
+ (define (split acc offset n)
+ (if (>= offset length)
+ (reverse! acc)
+ (let ((i (lookahead haystack offset)))
+ (if (or (eq? i #f) (= 0 n))
+ (reverse! (cons (substring haystack offset length) acc))
+ (split (cons (substring haystack offset i) acc)
+ (+ i 1) (- n 1))))))
+ (split '() 0 n)))
+
+(define (string-indexp haystack offset predicate)
+ (cond
+ ((= (string-length haystack) offset)
+ #f)
+ ((predicate (string-ref haystack offset))
+ offset)
+ (else
+ (string-indexp haystack (+ 1 offset) predicate))))
+
+;; Split HAYSTACK at each character that makes PREDICATE true at most
+;; N times.
+(define (string-splitp haystack predicate n)
+ (string-split-pln haystack predicate
+ (lambda (haystack offset)
+ (string-indexp haystack offset predicate))
+ n))
+(assert (equal? '("a" "b") (string-splitp "a b" char-whitespace? -1)))
+(assert (equal? '("a" "b") (string-splitp "a\tb" char-whitespace? -1)))
+(assert (equal? '("a" "" "b") (string-splitp "a \tb" char-whitespace? -1)))
+
+;; Split haystack at delimiter at most n times.
+(define (string-splitn haystack delimiter n)
+ (string-split-pln haystack
+ (lambda (c) (char=? c delimiter))
+ (lambda (haystack offset)
+ (string-index haystack delimiter offset))
+ n))
+(assert (= 2 (length (string-splitn "foo:bar:baz" #\: 1))))
+(assert (string=? "foo" (car (string-splitn "foo:bar:baz" #\: 1))))
+(assert (string=? "bar:baz" (cadr (string-splitn "foo:bar:baz" #\: 1))))
+
+;; Split haystack at delimiter.
+(define (string-split haystack delimiter)
+ (string-splitn haystack delimiter -1))
+(assert (= 3 (length (string-split "foo:bar:baz" #\:))))
+(assert (string=? "foo" (car (string-split "foo:bar:baz" #\:))))
+(assert (string=? "bar" (cadr (string-split "foo:bar:baz" #\:))))
+(assert (string=? "baz" (caddr (string-split "foo:bar:baz" #\:))))
+
+;; Split haystack at newlines.
+(define (string-split-newlines haystack)
+ (if *win32*
+ (map (lambda (line) (if (string-suffix? line "\r")
+ (substring line 0 (- (string-length line) 1))
+ line))
+ (string-split haystack #\newline))
+ (string-split haystack #\newline)))
+
+;; Trim the prefix of S containing only characters that make PREDICATE
+;; true.
+(define (string-ltrim predicate s)
+ (if (string=? s "")
+ ""
+ (let loop ((s' (string->list s)))
+ (if (predicate (car s'))
+ (loop (cdr s'))
+ (list->string s')))))
+(assert (string=? "" (string-ltrim char-whitespace? "")))
+(assert (string=? "foo" (string-ltrim char-whitespace? " foo")))
+
+;; Trim the suffix of S containing only characters that make PREDICATE
+;; true.
+(define (string-rtrim predicate s)
+ (if (string=? s "")
+ ""
+ (let loop ((s' (reverse! (string->list s))))
+ (if (predicate (car s'))
+ (loop (cdr s'))
+ (list->string (reverse! s'))))))
+(assert (string=? "" (string-rtrim char-whitespace? "")))
+(assert (string=? "foo" (string-rtrim char-whitespace? "foo ")))
+
+;; Trim both the prefix and suffix of S containing only characters
+;; that make PREDICATE true.
+(define (string-trim predicate s)
+ (string-ltrim predicate (string-rtrim predicate s)))
+(assert (string=? "" (string-trim char-whitespace? "")))
+(assert (string=? "foo" (string-trim char-whitespace? " foo ")))
+
+;; Check if needle is contained in haystack.
+(ffi-define (string-contains? haystack needle))
+(assert (string-contains? "Hallo" "llo"))
+(assert (not (string-contains? "Hallo" "olla")))
+
+;; Translate characters.
+(define (string-translate s from to)
+ (list->string (map (lambda (c)
+ (let ((i (string-index from c)))
+ (if i (string-ref to i) c))) (string->list s))))
+(assert (equal? (string-translate "foo/bar" "/" ".") "foo.bar"))
+
+;; Read a word from port P.
+(define (read-word . p)
+ (list->string
+ (let f ()
+ (let ((c (apply peek-char p)))
+ (cond
+ ((eof-object? c) '())
+ ((char-alphabetic? c)
+ (apply read-char p)
+ (cons c (f)))
+ (else
+ (apply read-char p)
+ '()))))))
+
+(define (list->string-reversed lst)
+ (let* ((len (length lst))
+ (str (make-string len)))
+ (let loop ((i (- len 1))
+ (l lst))
+ (if (< i 0)
+ (begin
+ (assert (null? l))
+ str)
+ (begin
+ (string-set! str i (car l))
+ (loop (- i 1) (cdr l)))))))
+
+;; Read a line from port P.
+(define (read-line . p)
+ (let loop ((acc '()))
+ (let ((c (apply peek-char p)))
+ (cond
+ ((eof-object? c)
+ (if (null? acc)
+ c ;; #eof
+ (list->string-reversed acc)))
+ ((char=? c #\newline)
+ (apply read-char p)
+ (list->string-reversed acc))
+ (else
+ (apply read-char p)
+ (loop (cons c acc)))))))
+
+;; Read everything from port P.
+(define (read-all . p)
+ (let loop ((acc (open-output-string)))
+ (let ((c (apply peek-char p)))
+ (cond
+ ((eof-object? c) (get-output-string acc))
+ (else
+ (write-char (apply read-char p) acc)
+ (loop acc))))))
+
+;;
+;; Windows support.
+;;
+
+;; Like call-with-input-file but opens the file in 'binary' mode.
+(define (call-with-binary-input-file filename proc)
+ (letfd ((fd (open filename (logior O_RDONLY O_BINARY))))
+ (proc (fdopen fd "rb"))))
+
+;; Like call-with-output-file but opens the file in 'binary' mode.
+(define (call-with-binary-output-file filename proc)
+ (letfd ((fd (open filename (logior O_WRONLY O_CREAT O_BINARY) #o600)))
+ (proc (fdopen fd "wb"))))
+
+;;
+;; Libc functions.
+;;
+
+;; Change the read/write offset.
+(ffi-define (seek fd offset whence))
+
+;; Constants for WHENCE.
+(ffi-define SEEK_SET)
+(ffi-define SEEK_CUR)
+(ffi-define SEEK_END)
+
+;; Get our process id.
+(ffi-define (getpid))
+
+;; Copy data from file descriptor SOURCE to every file descriptor in
+;; SINKS.
+(ffi-define (splice source . sinks))
+
+;;
+;; Random numbers.
+;;
+
+;; Seed the random number generator.
+(ffi-define (srandom seed))
+
+;; Get a pseudo-random number between 0 (inclusive) and SCALE
+;; (exclusive).
+(ffi-define (random scale))
+
+;; Create a string of the given SIZE containing pseudo-random data.
+(ffi-define (make-random-string size))
diff --git a/tests/gpgscm/main.c b/tests/gpgscm/main.c
new file mode 100644
index 0000000..f2b12aa
--- /dev/null
+++ b/tests/gpgscm/main.c
@@ -0,0 +1,362 @@
+/* TinyScheme-based test driver.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ * SPDX-License-Identifier: GPL-3.0-or-later
+ */
+
+#include <config.h>
+
+#include <assert.h>
+#include <ctype.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <gcrypt.h>
+#include <gpg-error.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#if HAVE_MMAP
+#include <sys/mman.h>
+#endif
+
+#include "private.h"
+#include "scheme.h"
+#include "scheme-private.h"
+#include "ffi.h"
+#include "../common/i18n.h"
+#include "../../common/argparse.h"
+#include "../../common/init.h"
+#include "../../common/logging.h"
+#include "../../common/strlist.h"
+#include "../../common/sysutils.h"
+#include "../../common/util.h"
+
+/* The TinyScheme banner. Unfortunately, it isn't in the header
+ file. */
+#define ts_banner "TinyScheme 1.41"
+
+int verbose;
+
+
+
+/* Constants to identify the commands and options. */
+enum cmd_and_opt_values
+ {
+ aNull = 0,
+ oVerbose = 'v',
+ };
+
+/* The list of commands and options. */
+static ARGPARSE_OPTS opts[] =
+ {
+ ARGPARSE_s_n (oVerbose, "verbose", N_("verbose")),
+ ARGPARSE_end (),
+ };
+
+char *scmpath = "";
+size_t scmpath_len = 0;
+
+/* Command line parsing. */
+static void
+parse_arguments (ARGPARSE_ARGS *pargs, ARGPARSE_OPTS *popts)
+{
+
+ while (gnupg_argparse (NULL, pargs, popts))
+ {
+ switch (pargs->r_opt)
+ {
+ case oVerbose:
+ verbose++;
+ break;
+
+ default:
+ pargs->err = ARGPARSE_PRINT_ERROR;
+ break;
+ }
+ }
+}
+
+/* Print usage information and provide strings for help. */
+static const char *
+my_strusage( int level )
+{
+ const char *p;
+
+ switch (level)
+ {
+ case 9: p = "GPL-3.0-or-later"; break;
+ case 11: p = "gpgscm (@GNUPG@)";
+ break;
+ case 13: p = VERSION; break;
+ case 14: p = GNUPG_DEF_COPYRIGHT_LINE; break;
+ case 17: p = PRINTABLE_OS_NAME; break;
+ case 19: p = _("Please report bugs to <@EMAIL@>.\n"); break;
+
+ case 1:
+ case 40:
+ p = _("Usage: gpgscm [options] [file] (-h for help)");
+ break;
+ case 41:
+ p = _("Syntax: gpgscm [options] [file]\n"
+ "Execute the given Scheme program, or spawn interactive shell.\n");
+ break;
+
+ default: p = NULL; break;
+ }
+ return p;
+}
+
+
+
+static int
+path_absolute_p (const char *p)
+{
+#if _WIN32
+ return ((strlen (p) > 2 && p[1] == ':' && (p[2] == '\\' || p[2] == '/'))
+ || p[0] == '\\' || p[0] == '/');
+#else
+ return p[0] == '/';
+#endif
+}
+
+
+/* Load the Scheme program from FILE_NAME. If FILE_NAME is not an
+ absolute path, and LOOKUP_IN_PATH is given, then it is qualified
+ with the values in scmpath until the file is found. */
+static gpg_error_t
+load (scheme *sc, char *file_name,
+ int lookup_in_cwd, int lookup_in_path)
+{
+ gpg_error_t err = 0;
+ size_t n;
+ const char *directory;
+ char *qualified_name = file_name;
+ int use_path;
+ FILE *h = NULL;
+
+ use_path =
+ lookup_in_path && ! (path_absolute_p (file_name) || scmpath_len == 0);
+
+ if (path_absolute_p (file_name) || lookup_in_cwd || scmpath_len == 0)
+ {
+ h = fopen (file_name, "r");
+ if (! h)
+ err = gpg_error_from_syserror ();
+ }
+
+ if (h == NULL && use_path)
+ for (directory = scmpath, n = scmpath_len; n;
+ directory += strlen (directory) + 1, n--)
+ {
+ if (asprintf (&qualified_name, "%s/%s", directory, file_name) < 0)
+ return gpg_error_from_syserror ();
+
+ h = fopen (qualified_name, "r");
+ if (h)
+ {
+ err = 0;
+ break;
+ }
+
+ if (n > 1)
+ {
+ free (qualified_name);
+ continue; /* Try again! */
+ }
+
+ err = gpg_error_from_syserror ();
+ }
+
+ if (h == NULL)
+ {
+ /* Failed and no more elements in scmpath to try. */
+ fprintf (stderr, "Could not read %s: %s.\n",
+ qualified_name, gpg_strerror (err));
+ if (lookup_in_path)
+ fprintf (stderr,
+ "Consider using GPGSCM_PATH to specify the location "
+ "of the Scheme library.\n");
+ goto leave;
+ }
+ if (verbose > 2)
+ fprintf (stderr, "Loading %s...\n", qualified_name);
+
+#if HAVE_MMAP
+ /* Always try to mmap the file. This allows the pages to be shared
+ * between processes. If anything fails, we fall back to using
+ * buffered streams. */
+ if (1)
+ {
+ struct stat st;
+ void *map;
+ size_t len;
+ int fd = fileno (h);
+
+ if (fd < 0)
+ goto fallback;
+
+ if (fstat (fd, &st))
+ goto fallback;
+
+ len = (size_t) st.st_size;
+ if ((off_t) len != st.st_size)
+ goto fallback; /* Truncated. */
+
+ map = mmap (NULL, len, PROT_READ, MAP_SHARED, fd, 0);
+ if (map == MAP_FAILED)
+ goto fallback;
+
+ scheme_load_memory (sc, map, len, qualified_name);
+ munmap (map, len);
+ }
+ else
+ fallback:
+#endif
+ scheme_load_named_file (sc, h, qualified_name);
+ fclose (h);
+
+ if (sc->retcode && sc->nesting)
+ {
+ fprintf (stderr, "%s: Unbalanced parenthesis\n", qualified_name);
+ err = gpg_error (GPG_ERR_GENERAL);
+ }
+
+ leave:
+ if (file_name != qualified_name)
+ free (qualified_name);
+ return err;
+}
+
+
+
+int
+main (int argc, char **argv)
+{
+ int retcode;
+ gpg_error_t err;
+ char *argv0;
+ ARGPARSE_ARGS pargs;
+ scheme *sc;
+ char *p;
+#if _WIN32
+ char pathsep = ';';
+#else
+ char pathsep = ':';
+#endif
+ char *script = NULL;
+
+ /* Save argv[0] so that we can re-exec. */
+ argv0 = argv[0];
+
+ /* Parse path. */
+ if (getenv ("GPGSCM_PATH"))
+ scmpath = getenv ("GPGSCM_PATH");
+
+ p = scmpath = strdup (scmpath);
+ if (p == NULL)
+ return 2;
+
+ if (*p)
+ scmpath_len++;
+ for (; *p; p++)
+ if (*p == pathsep)
+ *p = 0, scmpath_len++;
+
+ set_strusage (my_strusage);
+ log_set_prefix ("gpgscm", GPGRT_LOG_WITH_PREFIX);
+
+ /* Make sure that our subsystems are ready. */
+ i18n_init ();
+ init_common_subsystems (&argc, &argv);
+
+ if (!gcry_check_version (NEED_LIBGCRYPT_VERSION))
+ {
+ fputs ("libgcrypt version mismatch\n", stderr);
+ exit (2);
+ }
+
+ /* Parse the command line. */
+ pargs.argc = &argc;
+ pargs.argv = &argv;
+ pargs.flags = 0;
+ parse_arguments (&pargs, opts);
+ gnupg_argparse (NULL, &pargs, NULL);
+
+ if (log_get_errorcount (0))
+ exit (2);
+
+ sc = scheme_init_new_custom_alloc (gcry_malloc, gcry_free);
+ if (! sc) {
+ fprintf (stderr, "Could not initialize TinyScheme!\n");
+ return 2;
+ }
+ scheme_set_input_port_file (sc, stdin);
+ scheme_set_output_port_file (sc, stderr);
+
+ if (argc)
+ {
+ script = argv[0];
+ argc--, argv++;
+ }
+
+ err = load (sc, "init.scm", 0, 1);
+ if (! err)
+ err = load (sc, "ffi.scm", 0, 1);
+ if (! err)
+ err = ffi_init (sc, argv0, script ? script : "interactive",
+ argc, (const char **) argv);
+ if (! err)
+ err = load (sc, "lib.scm", 0, 1);
+ if (! err)
+ err = load (sc, "repl.scm", 0, 1);
+ if (! err)
+ err = load (sc, "xml.scm", 0, 1);
+ if (! err)
+ err = load (sc, "tests.scm", 0, 1);
+ if (! err)
+ err = load (sc, "gnupg.scm", 0, 1);
+ if (err)
+ {
+ fprintf (stderr, "Error initializing gpgscm: %s.\n",
+ gpg_strerror (err));
+ exit (2);
+ }
+
+ if (script == NULL)
+ {
+ /* Interactive shell. */
+ fprintf (stderr, "gpgscm/"ts_banner".\n");
+ scheme_load_string (sc, "(interactive-repl)");
+ }
+ else
+ {
+ err = load (sc, script, 1, 1);
+ if (err)
+ log_fatal ("%s: %s", script, gpg_strerror (err));
+ }
+
+ retcode = sc->retcode;
+ scheme_load_string (sc, "(*run-atexit-handlers*)");
+ scheme_deinit (sc);
+ xfree (sc);
+ return retcode;
+}
diff --git a/tests/gpgscm/makefile.scm b/tests/gpgscm/makefile.scm
new file mode 100644
index 0000000..32fae3a
--- /dev/null
+++ b/tests/gpgscm/makefile.scm
@@ -0,0 +1,76 @@
+;; Support for parsing Makefiles
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+(define (parse-makefile port key)
+ (define (is-continuation? tokens)
+ (string=? (last tokens) "\\"))
+ (define (valid-token? s)
+ (< 0 (string-length s)))
+ (define (drop-continuations tokens)
+ (let loop ((acc '()) (tks tokens))
+ (if (null? tks)
+ (reverse acc)
+ (loop (if (string=? "\\" (car tks))
+ acc
+ (cons (car tks) acc)) (cdr tks)))))
+ (let next ((acc '()) (found #f))
+ (let ((line (read-line port)))
+ (if (eof-object? line)
+ acc
+ (let ((tokens (filter valid-token?
+ (string-splitp (string-trim char-whitespace?
+ line)
+ char-whitespace? -1))))
+ (cond
+ ((or (null? tokens)
+ (string-prefix? (car tokens) "#")
+ (and (not found) (not (and (string=? key (car tokens))
+ (string=? "=" (cadr tokens))))))
+ (next acc found))
+ ((not found)
+ (assert (and (string=? key (car tokens))
+ (string=? "=" (cadr tokens))))
+ (if (is-continuation? tokens)
+ (next (drop-continuations (cddr tokens)) #t)
+ (drop-continuations (cddr tokens))))
+ (else
+ (assert found)
+ (if (is-continuation? tokens)
+ (next (append acc (drop-continuations tokens)) found)
+ (append acc (drop-continuations tokens))))))))))
+
+(define (parse-makefile-expand filename expand key)
+ (define (variable? v)
+ (and (string-prefix? v "$(") (string-suffix? v ")")))
+
+ (let expand-all ((values (parse-makefile (open-input-file filename) key)))
+ (if (any variable? values)
+ (expand-all
+ (let expand-one ((acc '()) (v values))
+ (cond
+ ((null? v)
+ acc)
+ ((variable? (car v))
+ (let ((makefile (open-input-file filename))
+ (key (substring (car v) 2 (- (string-length (car v)) 1))))
+ (expand-one (append acc (expand filename makefile key))
+ (cdr v))))
+ (else
+ (expand-one (append acc (list (car v))) (cdr v))))))
+ values)))
diff --git a/tests/gpgscm/opdefines.h b/tests/gpgscm/opdefines.h
new file mode 100644
index 0000000..61f7971
--- /dev/null
+++ b/tests/gpgscm/opdefines.h
@@ -0,0 +1,205 @@
+_OP_DEF("load", 1, 1, TST_STRING, OP_LOAD )
+_OP_DEF(0, 0, 0, 0, OP_T0LVL )
+_OP_DEF(0, 0, 0, 0, OP_T1LVL )
+_OP_DEF(0, 0, 0, 0, OP_READ_INTERNAL )
+_OP_DEF("gensym", 0, 0, 0, OP_GENSYM )
+_OP_DEF(0, 0, 0, 0, OP_VALUEPRINT )
+_OP_DEF(0, 0, 0, 0, OP_EVAL )
+#if USE_TRACING
+_OP_DEF(0, 0, 0, 0, OP_REAL_EVAL )
+#endif
+_OP_DEF(0, 0, 0, 0, OP_E0ARGS )
+_OP_DEF(0, 0, 0, 0, OP_E1ARGS )
+#if USE_HISTORY
+_OP_DEF(0, 0, 0, 0, OP_CALLSTACK_POP )
+#endif
+_OP_DEF(0, 0, 0, 0, OP_APPLY_CODE )
+_OP_DEF(0, 0, 0, 0, OP_APPLY )
+#if USE_TRACING
+_OP_DEF(0, 0, 0, 0, OP_REAL_APPLY )
+_OP_DEF("tracing", 1, 1, TST_NATURAL, OP_TRACING )
+#endif
+_OP_DEF(0, 0, 0, 0, OP_DOMACRO )
+_OP_DEF(0, 0, 0, 0, OP_LAMBDA )
+_OP_DEF(0, 0, 0, 0, OP_LAMBDA1 )
+_OP_DEF("make-closure", 1, 2, TST_PAIR TST_ENVIRONMENT, OP_MKCLOSURE )
+_OP_DEF(0, 0, 0, 0, OP_QUOTE )
+_OP_DEF(0, 0, 0, 0, OP_DEF0 )
+_OP_DEF(0, 0, 0, 0, OP_DEF1 )
+_OP_DEF("defined?", 1, 2, TST_SYMBOL TST_ENVIRONMENT, OP_DEFP )
+_OP_DEF(0, 0, 0, 0, OP_BEGIN )
+_OP_DEF(0, 0, 0, 0, OP_IF0 )
+_OP_DEF(0, 0, 0, 0, OP_IF1 )
+_OP_DEF(0, 0, 0, 0, OP_SET0 )
+_OP_DEF(0, 0, 0, 0, OP_SET1 )
+_OP_DEF(0, 0, 0, 0, OP_LET0 )
+_OP_DEF(0, 0, 0, 0, OP_LET1 )
+_OP_DEF(0, 0, 0, 0, OP_LET2 )
+_OP_DEF(0, 0, 0, 0, OP_LET0AST )
+_OP_DEF(0, 0, 0, 0, OP_LET1AST )
+_OP_DEF(0, 0, 0, 0, OP_LET2AST )
+_OP_DEF(0, 0, 0, 0, OP_LET0REC )
+_OP_DEF(0, 0, 0, 0, OP_LET1REC )
+_OP_DEF(0, 0, 0, 0, OP_LET2REC )
+_OP_DEF(0, 0, 0, 0, OP_COND0 )
+_OP_DEF(0, 0, 0, 0, OP_COND1 )
+_OP_DEF(0, 0, 0, 0, OP_DELAY )
+_OP_DEF(0, 0, 0, 0, OP_AND0 )
+_OP_DEF(0, 0, 0, 0, OP_AND1 )
+_OP_DEF(0, 0, 0, 0, OP_OR0 )
+_OP_DEF(0, 0, 0, 0, OP_OR1 )
+_OP_DEF(0, 0, 0, 0, OP_C0STREAM )
+_OP_DEF(0, 0, 0, 0, OP_C1STREAM )
+_OP_DEF(0, 0, 0, 0, OP_MACRO0 )
+_OP_DEF(0, 0, 0, 0, OP_MACRO1 )
+_OP_DEF(0, 0, 0, 0, OP_CASE0 )
+_OP_DEF(0, 0, 0, 0, OP_CASE1 )
+_OP_DEF(0, 0, 0, 0, OP_CASE2 )
+_OP_DEF("eval", 1, 2, TST_ANY TST_ENVIRONMENT, OP_PEVAL )
+_OP_DEF("apply", 1, INF_ARG, TST_NONE, OP_PAPPLY )
+_OP_DEF("call-with-current-continuation", 1, 1, TST_NONE, OP_CONTINUATION )
+#if USE_MATH
+_OP_DEF("inexact->exact", 1, 1, TST_NUMBER, OP_INEX2EX )
+_OP_DEF("exp", 1, 1, TST_NUMBER, OP_EXP )
+_OP_DEF("log", 1, 1, TST_NUMBER, OP_LOG )
+_OP_DEF("sin", 1, 1, TST_NUMBER, OP_SIN )
+_OP_DEF("cos", 1, 1, TST_NUMBER, OP_COS )
+_OP_DEF("tan", 1, 1, TST_NUMBER, OP_TAN )
+_OP_DEF("asin", 1, 1, TST_NUMBER, OP_ASIN )
+_OP_DEF("acos", 1, 1, TST_NUMBER, OP_ACOS )
+_OP_DEF("atan", 1, 2, TST_NUMBER, OP_ATAN )
+_OP_DEF("sqrt", 1, 1, TST_NUMBER, OP_SQRT )
+_OP_DEF("expt", 2, 2, TST_NUMBER, OP_EXPT )
+_OP_DEF("floor", 1, 1, TST_NUMBER, OP_FLOOR )
+_OP_DEF("ceiling", 1, 1, TST_NUMBER, OP_CEILING )
+_OP_DEF("truncate", 1, 1, TST_NUMBER, OP_TRUNCATE )
+_OP_DEF("round", 1, 1, TST_NUMBER, OP_ROUND )
+#endif
+_OP_DEF("+", 0, INF_ARG, TST_NUMBER, OP_ADD )
+_OP_DEF("-", 1, INF_ARG, TST_NUMBER, OP_SUB )
+_OP_DEF("*", 0, INF_ARG, TST_NUMBER, OP_MUL )
+_OP_DEF("/", 1, INF_ARG, TST_NUMBER, OP_DIV )
+_OP_DEF("quotient", 1, INF_ARG, TST_INTEGER, OP_INTDIV )
+_OP_DEF("remainder", 2, 2, TST_INTEGER, OP_REM )
+_OP_DEF("modulo", 2, 2, TST_INTEGER, OP_MOD )
+_OP_DEF("car", 1, 1, TST_PAIR, OP_CAR )
+_OP_DEF("cdr", 1, 1, TST_PAIR, OP_CDR )
+_OP_DEF("cons", 2, 2, TST_NONE, OP_CONS )
+_OP_DEF("set-car!", 2, 2, TST_PAIR TST_ANY, OP_SETCAR )
+_OP_DEF("set-cdr!", 2, 2, TST_PAIR TST_ANY, OP_SETCDR )
+_OP_DEF("char->integer", 1, 1, TST_CHAR, OP_CHAR2INT )
+_OP_DEF("integer->char", 1, 1, TST_NATURAL, OP_INT2CHAR )
+_OP_DEF("char-upcase", 1, 1, TST_CHAR, OP_CHARUPCASE )
+_OP_DEF("char-downcase", 1, 1, TST_CHAR, OP_CHARDNCASE )
+_OP_DEF("symbol->string", 1, 1, TST_SYMBOL, OP_SYM2STR )
+_OP_DEF("atom->string", 1, 2, TST_ANY TST_NATURAL, OP_ATOM2STR )
+_OP_DEF("string->symbol", 1, 1, TST_STRING, OP_STR2SYM )
+_OP_DEF("string->atom", 1, 2, TST_STRING TST_NATURAL, OP_STR2ATOM )
+_OP_DEF("make-string", 1, 2, TST_NATURAL TST_CHAR, OP_MKSTRING )
+_OP_DEF("string-length", 1, 1, TST_STRING, OP_STRLEN )
+_OP_DEF("string-ref", 2, 2, TST_STRING TST_NATURAL, OP_STRREF )
+_OP_DEF("string-set!", 3, 3, TST_STRING TST_NATURAL TST_CHAR, OP_STRSET )
+_OP_DEF("string-append", 0, INF_ARG, TST_STRING, OP_STRAPPEND )
+_OP_DEF("substring", 2, 3, TST_STRING TST_NATURAL, OP_SUBSTR )
+_OP_DEF("vector", 0, INF_ARG, TST_NONE, OP_VECTOR )
+_OP_DEF("make-vector", 1, 2, TST_NATURAL TST_ANY, OP_MKVECTOR )
+_OP_DEF("vector-length", 1, 1, TST_VECTOR, OP_VECLEN )
+_OP_DEF("vector-ref", 2, 2, TST_VECTOR TST_NATURAL, OP_VECREF )
+_OP_DEF("vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET )
+_OP_DEF("not", 1, 1, TST_NONE, OP_NOT )
+_OP_DEF("boolean?", 1, 1, TST_NONE, OP_BOOLP )
+_OP_DEF("eof-object?", 1, 1, TST_NONE, OP_EOFOBJP )
+_OP_DEF("null?", 1, 1, TST_NONE, OP_NULLP )
+_OP_DEF("=", 2, INF_ARG, TST_NUMBER, OP_NUMEQ )
+_OP_DEF("<", 2, INF_ARG, TST_NUMBER, OP_LESS )
+_OP_DEF(">", 2, INF_ARG, TST_NUMBER, OP_GRE )
+_OP_DEF("<=", 2, INF_ARG, TST_NUMBER, OP_LEQ )
+_OP_DEF(">=", 2, INF_ARG, TST_NUMBER, OP_GEQ )
+_OP_DEF("symbol?", 1, 1, TST_ANY, OP_SYMBOLP )
+_OP_DEF("number?", 1, 1, TST_ANY, OP_NUMBERP )
+_OP_DEF("string?", 1, 1, TST_ANY, OP_STRINGP )
+_OP_DEF("integer?", 1, 1, TST_ANY, OP_INTEGERP )
+_OP_DEF("real?", 1, 1, TST_ANY, OP_REALP )
+_OP_DEF("char?", 1, 1, TST_ANY, OP_CHARP )
+#if USE_CHAR_CLASSIFIERS
+_OP_DEF("char-alphabetic?", 1, 1, TST_CHAR, OP_CHARAP )
+_OP_DEF("char-numeric?", 1, 1, TST_CHAR, OP_CHARNP )
+_OP_DEF("char-whitespace?", 1, 1, TST_CHAR, OP_CHARWP )
+_OP_DEF("char-upper-case?", 1, 1, TST_CHAR, OP_CHARUP )
+_OP_DEF("char-lower-case?", 1, 1, TST_CHAR, OP_CHARLP )
+#endif
+_OP_DEF("port?", 1, 1, TST_ANY, OP_PORTP )
+_OP_DEF("input-port?", 1, 1, TST_ANY, OP_INPORTP )
+_OP_DEF("output-port?", 1, 1, TST_ANY, OP_OUTPORTP )
+_OP_DEF("procedure?", 1, 1, TST_ANY, OP_PROCP )
+_OP_DEF("pair?", 1, 1, TST_ANY, OP_PAIRP )
+_OP_DEF("list?", 1, 1, TST_ANY, OP_LISTP )
+_OP_DEF("environment?", 1, 1, TST_ANY, OP_ENVP )
+_OP_DEF("vector?", 1, 1, TST_ANY, OP_VECTORP )
+_OP_DEF("eq?", 2, 2, TST_ANY, OP_EQ )
+_OP_DEF("eqv?", 2, 2, TST_ANY, OP_EQV )
+_OP_DEF("force", 1, 1, TST_ANY, OP_FORCE )
+_OP_DEF(0, 0, 0, 0, OP_SAVE_FORCED )
+_OP_DEF("write", 1, 2, TST_ANY TST_OUTPORT, OP_WRITE )
+_OP_DEF("write-char", 1, 2, TST_CHAR TST_OUTPORT, OP_WRITE_CHAR )
+_OP_DEF("display", 1, 2, TST_ANY TST_OUTPORT, OP_DISPLAY )
+_OP_DEF("newline", 0, 1, TST_OUTPORT, OP_NEWLINE )
+_OP_DEF("error", 1, INF_ARG, TST_NONE, OP_ERR0 )
+_OP_DEF(0, 0, 0, 0, OP_ERR1 )
+_OP_DEF("reverse", 1, 1, TST_LIST, OP_REVERSE )
+_OP_DEF("reverse!", 1, 1, TST_LIST, OP_REVERSE_IN_PLACE )
+_OP_DEF("list*", 1, INF_ARG, TST_NONE, OP_LIST_STAR )
+_OP_DEF("append", 0, INF_ARG, TST_NONE, OP_APPEND )
+#if USE_PLIST
+_OP_DEF("set-symbol-property!", 3, 3, TST_SYMBOL TST_SYMBOL TST_ANY, OP_SET_SYMBOL_PROPERTY )
+_OP_DEF("symbol-property", 2, 2, TST_SYMBOL TST_SYMBOL, OP_SYMBOL_PROPERTY )
+#endif
+_OP_DEF(0, 0, 0, TST_NONE, OP_TAG_VALUE )
+_OP_DEF("make-tagged-value", 2, 2, TST_ANY TST_PAIR, OP_MK_TAGGED )
+_OP_DEF("get-tag", 1, 1, TST_ANY, OP_GET_TAG )
+_OP_DEF("quit", 0, 1, TST_NUMBER, OP_QUIT )
+_OP_DEF("gc", 0, 0, 0, OP_GC )
+_OP_DEF("gc-verbose", 0, 1, TST_NONE, OP_GCVERB )
+_OP_DEF("new-segment", 0, 1, TST_NUMBER, OP_NEWSEGMENT )
+_OP_DEF("oblist", 0, 0, 0, OP_OBLIST )
+_OP_DEF("current-input-port", 0, 0, 0, OP_CURR_INPORT )
+_OP_DEF("current-output-port", 0, 0, 0, OP_CURR_OUTPORT )
+_OP_DEF("open-input-file", 1, 1, TST_STRING, OP_OPEN_INFILE )
+_OP_DEF("open-output-file", 1, 1, TST_STRING, OP_OPEN_OUTFILE )
+_OP_DEF("open-input-output-file", 1, 1, TST_STRING, OP_OPEN_INOUTFILE )
+#if USE_STRING_PORTS
+_OP_DEF("open-input-string", 1, 1, TST_STRING, OP_OPEN_INSTRING )
+_OP_DEF("open-input-output-string", 1, 1, TST_STRING, OP_OPEN_INOUTSTRING )
+_OP_DEF("open-output-string", 0, 1, TST_STRING, OP_OPEN_OUTSTRING )
+_OP_DEF("get-output-string", 1, 1, TST_OUTPORT, OP_GET_OUTSTRING )
+#endif
+_OP_DEF("close-input-port", 1, 1, TST_INPORT, OP_CLOSE_INPORT )
+_OP_DEF("close-output-port", 1, 1, TST_OUTPORT, OP_CLOSE_OUTPORT )
+_OP_DEF("interaction-environment", 0, 0, 0, OP_INT_ENV )
+_OP_DEF("current-environment", 0, 0, 0, OP_CURR_ENV )
+_OP_DEF("read", 0, 1, TST_INPORT, OP_READ )
+_OP_DEF("read-char", 0, 1, TST_INPORT, OP_READ_CHAR )
+_OP_DEF("peek-char", 0, 1, TST_INPORT, OP_PEEK_CHAR )
+_OP_DEF("char-ready?", 0, 1, TST_INPORT, OP_CHAR_READY )
+_OP_DEF("set-input-port", 1, 1, TST_INPORT, OP_SET_INPORT )
+_OP_DEF("set-output-port", 1, 1, TST_OUTPORT, OP_SET_OUTPORT )
+_OP_DEF(0, 0, 0, 0, OP_RDSEXPR )
+_OP_DEF(0, 0, 0, 0, OP_RDLIST )
+_OP_DEF(0, 0, 0, 0, OP_RDDOT )
+_OP_DEF(0, 0, 0, 0, OP_RDQUOTE )
+_OP_DEF(0, 0, 0, 0, OP_RDQQUOTE )
+_OP_DEF(0, 0, 0, 0, OP_RDQQUOTEVEC )
+_OP_DEF(0, 0, 0, 0, OP_RDUNQUOTE )
+_OP_DEF(0, 0, 0, 0, OP_RDUQTSP )
+_OP_DEF(0, 0, 0, 0, OP_RDVEC )
+_OP_DEF(0, 0, 0, 0, OP_P0LIST )
+_OP_DEF(0, 0, 0, 0, OP_P1LIST )
+_OP_DEF(0, 0, 0, 0, OP_PVECFROM )
+_OP_DEF("length", 1, 1, TST_LIST, OP_LIST_LENGTH )
+_OP_DEF("assq", 2, 2, TST_NONE, OP_ASSQ )
+_OP_DEF("get-closure-code", 1, 1, TST_NONE, OP_GET_CLOSURE )
+_OP_DEF("closure?", 1, 1, TST_NONE, OP_CLOSUREP )
+_OP_DEF("macro?", 1, 1, TST_NONE, OP_MACROP )
+_OP_DEF("*vm-history*", 0, 0, TST_NONE, OP_VM_HISTORY )
+
+#undef _OP_DEF
diff --git a/tests/gpgscm/private.h b/tests/gpgscm/private.h
new file mode 100644
index 0000000..6e330e0
--- /dev/null
+++ b/tests/gpgscm/private.h
@@ -0,0 +1,26 @@
+/* TinyScheme-based test driver.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#ifndef __GPGSCM_PRIVATE_H__
+#define __GPGSCM_PRIVATE_H__
+
+extern int verbose;
+
+#endif /* __GPGSCM_PRIVATE_H__ */
diff --git a/tests/gpgscm/repl.scm b/tests/gpgscm/repl.scm
new file mode 100644
index 0000000..833ec0d
--- /dev/null
+++ b/tests/gpgscm/repl.scm
@@ -0,0 +1,69 @@
+;; A read-evaluate-print-loop for gpgscm.
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+;; Interactive repl using 'prompt' function. P must be a function
+;; that given the current entered prefix returns the prompt to
+;; display.
+(define (repl p environment)
+ (call/cc
+ (lambda (exit)
+ (let loop ((prefix ""))
+ (let ((line (prompt (p prefix))))
+ (if (and (not (eof-object? line)) (= 0 (string-length line)))
+ (exit (loop prefix)))
+ (if (not (eof-object? line))
+ (let* ((next (string-append prefix line))
+ (c (catch (begin (echo "Parse error:" *error*)
+ (loop prefix))
+ (read (open-input-string next)))))
+ (if (not (eof-object? c))
+ (begin
+ (catch (begin
+ (display (car *error*))
+ (when (and (cadr *error*)
+ (not (null? (cadr *error*))))
+ (display ": ")
+ (write (cadr *error*)))
+ (newline)
+ (vm-history-print (caddr *error*)))
+ (echo " ===>" (eval c environment)))
+ (exit (loop ""))))
+ (exit (loop next)))))))))
+
+(define (prompt-append-prefix prompt prefix)
+ (string-append prompt (if (> (string-length prefix) 0)
+ (string-append prefix "...")
+ "> ")))
+
+;; Default repl run by main.c.
+(define (interactive-repl . environment)
+ (repl (lambda (p) (prompt-append-prefix "gpgscm " p))
+ (if (null? environment) (interaction-environment) (car environment))))
+
+;; Ask a yes/no question.
+(define (prompt-yes-no? question default)
+ (let ((answer (prompt (string-append question "? ["
+ (if default "Y/n" "y/N") "] "))))
+ (cond
+ ((= 0 (string-length answer))
+ default)
+ ((or (equal? "y" answer) (equal? "Y" answer))
+ #t)
+ (else
+ #f))))
diff --git a/tests/gpgscm/scheme-config.h b/tests/gpgscm/scheme-config.h
new file mode 100644
index 0000000..15ca969
--- /dev/null
+++ b/tests/gpgscm/scheme-config.h
@@ -0,0 +1,32 @@
+/* TinyScheme configuration.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#define STANDALONE 0
+#define USE_MATH 0
+#define USE_CHAR_CLASSIFIERS 1
+#define USE_ASCII_NAMES 1
+#define USE_STRING_PORTS 1
+#define USE_ERROR_HOOK 1
+#define USE_TRACING 1
+#define USE_COLON_HOOK 1
+#define USE_DL 0
+#define USE_PLIST 0
+#define USE_INTERFACE 1
+#define SHOW_ERROR_LINE 1
diff --git a/tests/gpgscm/scheme-private.h b/tests/gpgscm/scheme-private.h
new file mode 100644
index 0000000..7f92bda
--- /dev/null
+++ b/tests/gpgscm/scheme-private.h
@@ -0,0 +1,274 @@
+/* scheme-private.h */
+
+#ifndef _SCHEME_PRIVATE_H
+#define _SCHEME_PRIVATE_H
+
+#include <stdint.h>
+#include "scheme.h"
+/*------------------ Ugly internals -----------------------------------*/
+/*------------------ Of interest only to FFI users --------------------*/
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+enum scheme_port_kind {
+ port_free=0,
+ port_file=1,
+ port_string=2,
+ port_srfi6=4,
+ port_input=16,
+ port_output=32,
+ port_saw_EOF=64
+};
+
+typedef struct port {
+ unsigned char kind;
+ union {
+ struct {
+ FILE *file;
+ int closeit;
+ } stdio;
+ struct {
+ char *start;
+ char *past_the_end;
+ char *curr;
+ } string;
+ } rep;
+#if SHOW_ERROR_LINE
+ pointer curr_line;
+ pointer filename;
+#endif
+} port;
+
+/* cell structure */
+struct cell {
+ uintptr_t _flag;
+ union {
+ num _number;
+ struct {
+ char *_svalue;
+ int _length;
+ } _string;
+ port *_port;
+ foreign_func _ff;
+ struct {
+ struct cell *_car;
+ struct cell *_cdr;
+ } _cons;
+ struct {
+ size_t _length;
+ pointer _elements[0];
+ } _vector;
+ struct {
+ char *_data;
+ const foreign_object_vtable *_vtable;
+ } _foreign_object;
+ } _object;
+};
+
+#if USE_HISTORY
+/* The history is a two-dimensional ring buffer. A donut-shaped data
+ * structure. This data structure is inspired by MIT/GNU Scheme. */
+struct history {
+ /* Number of calls to store. Must be a power of two. */
+ size_t N;
+
+ /* Number of tail-calls to store in each call frame. Must be a
+ * power of two. */
+ size_t M;
+
+ /* Masks for fast index calculations. */
+ size_t mask_N;
+ size_t mask_M;
+
+ /* A vector of size N containing calls. */
+ pointer callstack;
+
+ /* A vector of size N containing vectors of size M containing tail
+ * calls. */
+ pointer tailstacks;
+
+ /* Our current position. */
+ size_t n;
+ size_t *m;
+};
+#endif
+
+struct scheme {
+/* arrays for segments */
+func_alloc malloc;
+func_dealloc free;
+
+/* return code */
+int retcode;
+int tracing;
+
+
+#ifndef CELL_SEGSIZE
+#define CELL_SEGSIZE 5000 /* # of cells in one segment */
+#endif
+
+/* If less than # of cells are recovered in a garbage collector run,
+ * allocate a new cell segment to avoid fruitless collection cycles in
+ * the near future. */
+#ifndef CELL_MINRECOVER
+#define CELL_MINRECOVER (CELL_SEGSIZE >> 2)
+#endif
+struct cell_segment *cell_segments;
+
+/* We use 4 registers. */
+pointer args; /* register for arguments of function */
+pointer envir; /* stack register for current environment */
+pointer code; /* register for current code */
+pointer dump; /* stack register for next evaluation */
+pointer frame_freelist;
+
+#if USE_HISTORY
+struct history history; /* we keep track of the call history for
+ * error messages */
+#endif
+
+int interactive_repl; /* are we in an interactive REPL? */
+
+struct cell _sink;
+pointer sink; /* when mem. alloc. fails */
+struct cell _NIL;
+pointer NIL; /* special cell representing empty cell */
+struct cell _HASHT;
+pointer T; /* special cell representing #t */
+struct cell _HASHF;
+pointer F; /* special cell representing #f */
+struct cell _EOF_OBJ;
+pointer EOF_OBJ; /* special cell representing end-of-file object */
+pointer oblist; /* pointer to symbol table */
+pointer global_env; /* pointer to global environment */
+pointer c_nest; /* stack for nested calls from C */
+
+/* global pointers to special symbols */
+pointer LAMBDA; /* pointer to syntax lambda */
+pointer QUOTE; /* pointer to syntax quote */
+
+pointer QQUOTE; /* pointer to symbol quasiquote */
+pointer UNQUOTE; /* pointer to symbol unquote */
+pointer UNQUOTESP; /* pointer to symbol unquote-splicing */
+pointer FEED_TO; /* => */
+pointer COLON_HOOK; /* *colon-hook* */
+pointer ERROR_HOOK; /* *error-hook* */
+pointer SHARP_HOOK; /* *sharp-hook* */
+#if USE_COMPILE_HOOK
+pointer COMPILE_HOOK; /* *compile-hook* */
+#endif
+
+pointer free_cell; /* pointer to top of free cells */
+long fcells; /* # of free cells */
+size_t inhibit_gc; /* nesting of gc_disable */
+size_t reserved_cells; /* # of reserved cells */
+#ifndef NDEBUG
+int reserved_lineno; /* location of last reservation */
+#endif
+
+pointer inport;
+pointer outport;
+pointer save_inport;
+pointer loadport;
+
+#ifndef MAXFIL
+#define MAXFIL 64
+#endif
+port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */
+int nesting_stack[MAXFIL];
+int file_i;
+int nesting;
+
+char gc_verbose; /* if gc_verbose is not zero, print gc status */
+char no_memory; /* Whether mem. alloc. has failed */
+
+#ifndef LINESIZE
+#define LINESIZE 1024
+#endif
+char linebuff[LINESIZE];
+#ifndef STRBUFFSIZE
+#define STRBUFFSIZE 256
+#endif
+char *strbuff;
+size_t strbuff_size;
+FILE *tmpfp;
+int tok;
+int print_flag;
+pointer value;
+unsigned int flags;
+
+void *ext_data; /* For the benefit of foreign functions */
+long gensym_cnt;
+
+const struct scheme_interface *vptr;
+};
+
+/* operator code */
+enum scheme_opcodes {
+#define _OP_DEF(A,B,C,D,OP) OP,
+#include "opdefines.h"
+ OP_MAXDEFINED
+};
+
+
+#define cons(sc,a,b) _cons(sc,a,b,0)
+#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
+
+int is_string(pointer p);
+char *string_value(pointer p);
+int is_number(pointer p);
+num nvalue(pointer p);
+long ivalue(pointer p);
+double rvalue(pointer p);
+int is_integer(pointer p);
+int is_real(pointer p);
+int is_character(pointer p);
+long charvalue(pointer p);
+int is_vector(pointer p);
+
+int is_port(pointer p);
+
+int is_pair(pointer p);
+pointer pair_car(pointer p);
+pointer pair_cdr(pointer p);
+pointer set_car(pointer p, pointer q);
+pointer set_cdr(pointer p, pointer q);
+
+int is_symbol(pointer p);
+char *symname(pointer p);
+int hasprop(pointer p);
+
+int is_syntax(pointer p);
+int is_proc(pointer p);
+int is_foreign(pointer p);
+char *syntaxname(pointer p);
+int is_closure(pointer p);
+#ifdef USE_MACRO
+int is_macro(pointer p);
+#endif
+pointer closure_code(pointer p);
+pointer closure_env(pointer p);
+
+int is_continuation(pointer p);
+int is_promise(pointer p);
+int is_environment(pointer p);
+int is_immutable(pointer p);
+void setimmutable(pointer p);
+
+int is_foreign_object(pointer p);
+const foreign_object_vtable *get_foreign_object_vtable(pointer p);
+void *get_foreign_object_data(pointer p);
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/tests/gpgscm/scheme.c b/tests/gpgscm/scheme.c
new file mode 100644
index 0000000..86d70b3
--- /dev/null
+++ b/tests/gpgscm/scheme.c
@@ -0,0 +1,6043 @@
+/* T I N Y S C H E M E 1 . 4 1
+ * Dimitrios Souflis (dsouflis@acm.org)
+ * Based on MiniScheme (original credits follow)
+ * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)
+ * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
+ * (MINISCM) This version has been modified by R.C. Secrist.
+ * (MINISCM)
+ * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
+ * (MINISCM)
+ * (MINISCM) This is a revised and modified version by Akira KIDA.
+ * (MINISCM) current version is 0.85k4 (15 May 1994)
+ *
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#define _SCHEME_SOURCE
+#include "scheme-private.h"
+#ifndef WIN32
+# include <unistd.h>
+#endif
+#ifdef WIN32
+#define snprintf _snprintf
+#endif
+#if USE_DL
+# include "dynload.h"
+#endif
+#if USE_MATH
+# include <math.h>
+#endif
+
+#include <assert.h>
+#include <limits.h>
+#include <stdint.h>
+#include <float.h>
+#include <ctype.h>
+
+#if USE_STRCASECMP
+#include <strings.h>
+# ifndef __APPLE__
+# define stricmp strcasecmp
+# endif
+#endif
+
+#include "gpgrt.h" /* For GGPRT_GCC_VERSION */
+
+/* Used for documentation purposes, to signal functions in 'interface' */
+#define INTERFACE
+
+#define TOK_EOF (-1)
+#define TOK_LPAREN 0
+#define TOK_RPAREN 1
+#define TOK_DOT 2
+#define TOK_ATOM 3
+#define TOK_QUOTE 4
+#define TOK_COMMENT 5
+#define TOK_DQUOTE 6
+#define TOK_BQUOTE 7
+#define TOK_COMMA 8
+#define TOK_ATMARK 9
+#define TOK_SHARP 10
+#define TOK_SHARP_CONST 11
+#define TOK_VEC 12
+
+#define BACKQUOTE '`'
+#define DELIMITERS "()\";\f\t\v\n\r "
+
+/*
+ * Basic memory allocation units
+ */
+
+#define banner "TinyScheme 1.41"
+
+#include <string.h>
+#include <stddef.h>
+#include <stdlib.h>
+
+#ifdef __APPLE__
+static int stricmp(const char *s1, const char *s2)
+{
+ unsigned char c1, c2;
+ do {
+ c1 = tolower(*s1);
+ c2 = tolower(*s2);
+ if (c1 < c2)
+ return -1;
+ else if (c1 > c2)
+ return 1;
+ s1++, s2++;
+ } while (c1 != 0);
+ return 0;
+}
+#endif /* __APPLE__ */
+
+#if USE_STRLWR && !defined(HAVE_STRLWR)
+static const char *strlwr(char *s) {
+ const char *p=s;
+ while(*s) {
+ *s=tolower(*s);
+ s++;
+ }
+ return p;
+}
+#endif
+
+#ifndef prompt
+# define prompt "ts> "
+#endif
+
+#ifndef InitFile
+# define InitFile "init.scm"
+#endif
+
+#ifndef FIRST_CELLSEGS
+# define FIRST_CELLSEGS 3
+#endif
+
+
+
+/* All types have the LSB set. The garbage collector takes advantage
+ * of that to identify types. */
+enum scheme_types {
+ T_STRING = 1 << 1 | 1,
+ T_NUMBER = 2 << 1 | 1,
+ T_SYMBOL = 3 << 1 | 1,
+ T_PROC = 4 << 1 | 1,
+ T_PAIR = 5 << 1 | 1,
+ T_CLOSURE = 6 << 1 | 1,
+ T_CONTINUATION = 7 << 1 | 1,
+ T_FOREIGN = 8 << 1 | 1,
+ T_CHARACTER = 9 << 1 | 1,
+ T_PORT = 10 << 1 | 1,
+ T_VECTOR = 11 << 1 | 1,
+ T_MACRO = 12 << 1 | 1,
+ T_PROMISE = 13 << 1 | 1,
+ T_ENVIRONMENT = 14 << 1 | 1,
+ T_FOREIGN_OBJECT = 15 << 1 | 1,
+ T_BOOLEAN = 16 << 1 | 1,
+ T_NIL = 17 << 1 | 1,
+ T_EOF_OBJ = 18 << 1 | 1,
+ T_SINK = 19 << 1 | 1,
+ T_FRAME = 20 << 1 | 1,
+ T_LAST_SYSTEM_TYPE = 20 << 1 | 1
+};
+
+static const char *
+type_to_string (enum scheme_types typ)
+{
+ switch (typ)
+ {
+ case T_STRING: return "string";
+ case T_NUMBER: return "number";
+ case T_SYMBOL: return "symbol";
+ case T_PROC: return "proc";
+ case T_PAIR: return "pair";
+ case T_CLOSURE: return "closure";
+ case T_CONTINUATION: return "continuation";
+ case T_FOREIGN: return "foreign";
+ case T_CHARACTER: return "character";
+ case T_PORT: return "port";
+ case T_VECTOR: return "vector";
+ case T_MACRO: return "macro";
+ case T_PROMISE: return "promise";
+ case T_ENVIRONMENT: return "environment";
+ case T_FOREIGN_OBJECT: return "foreign object";
+ case T_BOOLEAN: return "boolean";
+ case T_NIL: return "nil";
+ case T_EOF_OBJ: return "eof object";
+ case T_SINK: return "sink";
+ case T_FRAME: return "frame";
+ }
+ assert (! "not reached");
+ return "?";
+}
+
+/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
+#define TYPE_BITS 6
+#define ADJ (1 << TYPE_BITS)
+#define T_MASKTYPE (ADJ - 1)
+ /* 0000000000111111 */
+#define T_TAGGED 1024 /* 0000010000000000 */
+#define T_FINALIZE 2048 /* 0000100000000000 */
+#define T_SYNTAX 4096 /* 0001000000000000 */
+#define T_IMMUTABLE 8192 /* 0010000000000000 */
+#define T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
+#define CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
+#define MARK 32768 /* 1000000000000000 */
+#define UNMARK 32767 /* 0111111111111111 */
+
+
+static num num_add(num a, num b);
+static num num_mul(num a, num b);
+static num num_div(num a, num b);
+static num num_intdiv(num a, num b);
+static num num_sub(num a, num b);
+static num num_rem(num a, num b);
+static num num_mod(num a, num b);
+static int num_eq(num a, num b);
+static int num_gt(num a, num b);
+static int num_ge(num a, num b);
+static int num_lt(num a, num b);
+static int num_le(num a, num b);
+
+#if USE_MATH
+static double round_per_R5RS(double x);
+#endif
+static int is_zero_double(double x);
+static INLINE int num_is_integer(pointer p) {
+ return ((p)->_object._number.is_fixnum);
+}
+
+static const struct num num_zero = { 1, {0} };
+static const struct num num_one = { 1, {1} };
+
+/* macros for cell operations */
+#define typeflag(p) ((p)->_flag)
+#define type(p) (typeflag(p)&T_MASKTYPE)
+#define settype(p, typ) (typeflag(p) = (typeflag(p) & ~T_MASKTYPE) | (typ))
+
+INTERFACE INLINE int is_string(pointer p) { return (type(p)==T_STRING); }
+#define strvalue(p) ((p)->_object._string._svalue)
+#define strlength(p) ((p)->_object._string._length)
+
+INTERFACE static int is_list(scheme *sc, pointer p);
+INTERFACE INLINE int is_vector(pointer p) { return (type(p)==T_VECTOR); }
+/* Given a vector, return it's length. */
+#define vector_length(v) (v)->_object._vector._length
+/* Given a vector length, compute the amount of cells required to
+ * represent it. */
+#define vector_size(len) (1 + ((len) - 1 + 2) / 3)
+INTERFACE static void fill_vector(pointer vec, pointer obj);
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem);
+INTERFACE static pointer vector_elem(pointer vec, int ielem);
+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
+INTERFACE INLINE int is_number(pointer p) { return (type(p)==T_NUMBER); }
+INTERFACE INLINE int is_integer(pointer p) {
+ if (!is_number(p))
+ return 0;
+ if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
+ return 1;
+ return 0;
+}
+
+INTERFACE INLINE int is_real(pointer p) {
+ return is_number(p) && (!(p)->_object._number.is_fixnum);
+}
+
+INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
+INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
+INLINE num nvalue(pointer p) { return ((p)->_object._number); }
+INTERFACE long ivalue(pointer p) { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
+INTERFACE double rvalue(pointer p) { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
+#define ivalue_unchecked(p) ((p)->_object._number.value.ivalue)
+#define rvalue_unchecked(p) ((p)->_object._number.value.rvalue)
+#define set_num_integer(p) (p)->_object._number.is_fixnum=1;
+#define set_num_real(p) (p)->_object._number.is_fixnum=0;
+INTERFACE long charvalue(pointer p) { return ivalue_unchecked(p); }
+
+INTERFACE INLINE int is_port(pointer p) { return (type(p)==T_PORT); }
+INTERFACE INLINE int is_inport(pointer p) { return is_port(p) && p->_object._port->kind & port_input; }
+INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }
+
+INTERFACE INLINE int is_pair(pointer p) { return (type(p)==T_PAIR); }
+#define car(p) ((p)->_object._cons._car)
+#define cdr(p) ((p)->_object._cons._cdr)
+INTERFACE pointer pair_car(pointer p) { return car(p); }
+INTERFACE pointer pair_cdr(pointer p) { return cdr(p); }
+INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
+INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }
+
+INTERFACE INLINE int is_symbol(pointer p) { return (type(p)==T_SYMBOL); }
+INTERFACE INLINE char *symname(pointer p) { return strvalue(car(p)); }
+#if USE_PLIST
+SCHEME_EXPORT INLINE int hasprop(pointer p) { return (is_symbol(p)); }
+#define symprop(p) cdr(p)
+#endif
+
+INTERFACE INLINE int is_syntax(pointer p) { return (typeflag(p)&T_SYNTAX); }
+INTERFACE INLINE int is_proc(pointer p) { return (type(p)==T_PROC); }
+INTERFACE INLINE int is_foreign(pointer p) { return (type(p)==T_FOREIGN); }
+INTERFACE INLINE char *syntaxname(pointer p) { return strvalue(car(p)); }
+#define procnum(p) ivalue_unchecked(p)
+static const char *procname(pointer x);
+
+INTERFACE INLINE int is_closure(pointer p) { return (type(p)==T_CLOSURE); }
+INTERFACE INLINE int is_macro(pointer p) { return (type(p)==T_MACRO); }
+INTERFACE INLINE pointer closure_code(pointer p) { return car(p); }
+INTERFACE INLINE pointer closure_env(pointer p) { return cdr(p); }
+
+INTERFACE INLINE int is_continuation(pointer p) { return (type(p)==T_CONTINUATION); }
+#define cont_dump(p) cdr(p)
+
+INTERFACE INLINE int is_foreign_object(pointer p) { return (type(p)==T_FOREIGN_OBJECT); }
+INTERFACE const foreign_object_vtable *get_foreign_object_vtable(pointer p) {
+ return p->_object._foreign_object._vtable;
+}
+INTERFACE void *get_foreign_object_data(pointer p) {
+ return p->_object._foreign_object._data;
+}
+
+/* To do: promise should be forced ONCE only */
+INTERFACE INLINE int is_promise(pointer p) { return (type(p)==T_PROMISE); }
+
+INTERFACE INLINE int is_environment(pointer p) { return (type(p)==T_ENVIRONMENT); }
+#define setenvironment(p) typeflag(p) = T_ENVIRONMENT
+
+INTERFACE INLINE int is_frame(pointer p) { return (type(p) == T_FRAME); }
+#define setframe(p) settype(p, T_FRAME)
+
+#define is_atom(p) (typeflag(p)&T_ATOM)
+#define setatom(p) typeflag(p) |= T_ATOM
+#define clratom(p) typeflag(p) &= CLRATOM
+
+#define is_mark(p) (typeflag(p)&MARK)
+#define setmark(p) typeflag(p) |= MARK
+#define clrmark(p) typeflag(p) &= UNMARK
+
+INTERFACE INLINE int is_immutable(pointer p) { return (typeflag(p)&T_IMMUTABLE); }
+/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/
+INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
+
+#define caar(p) car(car(p))
+#define cadr(p) car(cdr(p))
+#define cdar(p) cdr(car(p))
+#define cddr(p) cdr(cdr(p))
+#define cadar(p) car(cdr(car(p)))
+#define caddr(p) car(cdr(cdr(p)))
+#define cdaar(p) cdr(car(car(p)))
+#define cadaar(p) car(cdr(car(car(p))))
+#define cadddr(p) car(cdr(cdr(cdr(p))))
+#define cddddr(p) cdr(cdr(cdr(cdr(p))))
+
+#if USE_HISTORY
+static pointer history_flatten(scheme *sc);
+static void history_mark(scheme *sc);
+#else
+# define history_mark(SC) (void) 0
+# define history_flatten(SC) (SC)->NIL
+#endif
+
+#if USE_CHAR_CLASSIFIERS
+static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
+static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
+static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
+static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
+static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
+#endif
+
+#if USE_ASCII_NAMES
+static const char charnames[32][3]={
+ "nul",
+ "soh",
+ "stx",
+ "etx",
+ "eot",
+ "enq",
+ "ack",
+ "bel",
+ "bs",
+ "ht",
+ "lf",
+ "vt",
+ "ff",
+ "cr",
+ "so",
+ "si",
+ "dle",
+ "dc1",
+ "dc2",
+ "dc3",
+ "dc4",
+ "nak",
+ "syn",
+ "etb",
+ "can",
+ "em",
+ "sub",
+ "esc",
+ "fs",
+ "gs",
+ "rs",
+ "us"
+};
+
+static int is_ascii_name(const char *name, int *pc) {
+ int i;
+ for(i=0; i<32; i++) {
+ if (strncasecmp(name, charnames[i], 3) == 0) {
+ *pc=i;
+ return 1;
+ }
+ }
+ if (strcasecmp(name, "del") == 0) {
+ *pc=127;
+ return 1;
+ }
+ return 0;
+}
+
+#endif
+
+static int file_push(scheme *sc, pointer fname);
+static void file_pop(scheme *sc);
+static int file_interactive(scheme *sc);
+static INLINE int is_one_of(char *s, int c);
+static int alloc_cellseg(scheme *sc, int n);
+static long binary_decode(const char *s);
+static INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
+static pointer _get_cell(scheme *sc, pointer a, pointer b);
+static pointer reserve_cells(scheme *sc, int n);
+static pointer get_consecutive_cells(scheme *sc, int n);
+static pointer find_consecutive_cells(scheme *sc, int n);
+static int finalize_cell(scheme *sc, pointer a);
+static int count_consecutive_cells(pointer x, int needed);
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, int all);
+static pointer mk_number(scheme *sc, num n);
+static char *store_string(scheme *sc, int len, const char *str, char fill);
+static pointer mk_vector(scheme *sc, int len);
+static pointer mk_atom(scheme *sc, char *q);
+static pointer mk_sharp_const(scheme *sc, char *name);
+static pointer mk_port(scheme *sc, port *p);
+static pointer port_from_filename(scheme *sc, const char *fn, int prop);
+static pointer port_from_file(scheme *sc, FILE *, int prop);
+static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop);
+static port *port_rep_from_filename(scheme *sc, const char *fn, int prop);
+static port *port_rep_from_file(scheme *sc, FILE *, int prop);
+static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop);
+static void port_close(scheme *sc, pointer p, int flag);
+static void mark(pointer a);
+static void gc(scheme *sc, pointer a, pointer b);
+static int basic_inchar(port *pt);
+static int inchar(scheme *sc);
+static void backchar(scheme *sc, int c);
+static char *readstr_upto(scheme *sc, char *delim);
+static pointer readstrexp(scheme *sc);
+static INLINE int skipspace(scheme *sc);
+static int token(scheme *sc);
+static void printslashstring(scheme *sc, char *s, int len);
+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen);
+static void printatom(scheme *sc, pointer l, int f);
+static pointer mk_proc(scheme *sc, enum scheme_opcodes op);
+static pointer mk_closure(scheme *sc, pointer c, pointer e);
+static pointer mk_continuation(scheme *sc, pointer d);
+static pointer reverse(scheme *sc, pointer term, pointer list);
+static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
+static pointer revappend(scheme *sc, pointer a, pointer b);
+static void dump_stack_preallocate_frame(scheme *sc);
+static void dump_stack_mark(scheme *);
+struct op_code_info {
+ char name[31]; /* strlen ("call-with-current-continuation") + 1 */
+ unsigned char min_arity;
+ unsigned char max_arity;
+ char arg_tests_encoding[3];
+};
+static const struct op_code_info dispatch_table[];
+static int check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size);
+static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
+static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name);
+static int syntaxnum(scheme *sc, pointer p);
+static void assign_proc(scheme *sc, enum scheme_opcodes, const char *name);
+
+#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
+#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
+
+static num num_add(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue+b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_mul(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue*b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_div(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue/b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_intdiv(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue/b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_sub(num a, num b) {
+ num ret;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(ret.is_fixnum) {
+ ret.value.ivalue= a.value.ivalue-b.value.ivalue;
+ } else {
+ ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
+ }
+ return ret;
+}
+
+static num num_rem(num a, num b) {
+ num ret;
+ long e1, e2, res;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ e1=num_ivalue(a);
+ e2=num_ivalue(b);
+ res=e1%e2;
+ /* remainder should have same sign as second operand */
+ if (res > 0) {
+ if (e1 < 0) {
+ res -= labs(e2);
+ }
+ } else if (res < 0) {
+ if (e1 > 0) {
+ res += labs(e2);
+ }
+ }
+ ret.value.ivalue=res;
+ return ret;
+}
+
+static num num_mod(num a, num b) {
+ num ret;
+ long e1, e2, res;
+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
+ e1=num_ivalue(a);
+ e2=num_ivalue(b);
+ res=e1%e2;
+ /* modulo should have same sign as second operand */
+ if (res * e2 < 0) {
+ res += e2;
+ }
+ ret.value.ivalue=res;
+ return ret;
+}
+
+static int num_eq(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue==b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)==num_rvalue(b);
+ }
+ return ret;
+}
+
+
+static int num_gt(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue>b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)>num_rvalue(b);
+ }
+ return ret;
+}
+
+static int num_ge(num a, num b) {
+ return !num_lt(a,b);
+}
+
+static int num_lt(num a, num b) {
+ int ret;
+ int is_fixnum=a.is_fixnum && b.is_fixnum;
+ if(is_fixnum) {
+ ret= a.value.ivalue<b.value.ivalue;
+ } else {
+ ret=num_rvalue(a)<num_rvalue(b);
+ }
+ return ret;
+}
+
+static int num_le(num a, num b) {
+ return !num_gt(a,b);
+}
+
+#if USE_MATH
+/* Round to nearest. Round to even if midway */
+static double round_per_R5RS(double x) {
+ double fl=floor(x);
+ double ce=ceil(x);
+ double dfl=x-fl;
+ double dce=ce-x;
+ if(dfl>dce) {
+ return ce;
+ } else if(dfl<dce) {
+ return fl;
+ } else {
+ if(fmod(fl,2.0)==0.0) { /* I imagine this holds */
+ return fl;
+ } else {
+ return ce;
+ }
+ }
+}
+#endif
+
+static int is_zero_double(double x) {
+ return x<DBL_MIN && x>-DBL_MIN;
+}
+
+static long binary_decode(const char *s) {
+ long x=0;
+
+ while(*s!=0 && (*s=='1' || *s=='0')) {
+ x<<=1;
+ x+=*s-'0';
+ s++;
+ }
+
+ return x;
+}
+
+
+
+/*
+ * Copying values.
+ *
+ * Occasionally, we need to copy a value from one location in the
+ * storage to another. Scheme objects are fine. Some primitive
+ * objects, however, require finalization, usually to free resources.
+ *
+ * For these values, we either make a copy or acquire a reference.
+ */
+
+/*
+ * Copy SRC to DST.
+ *
+ * Copies the representation of SRC to DST. This makes SRC
+ * indistinguishable from DST from the perspective of a Scheme
+ * expression modulo the fact that they reside at a different location
+ * in the store.
+ *
+ * Conditions:
+ *
+ * - SRC must not be a vector.
+ * - Caller must ensure that any resources associated with the
+ * value currently stored in DST is accounted for.
+ */
+static void
+copy_value(scheme *sc, pointer dst, pointer src)
+{
+ memcpy(dst, src, sizeof *src);
+
+ /* We may need to make a copy or acquire a reference. */
+ if (typeflag(dst) & T_FINALIZE)
+ switch (type(dst)) {
+ case T_STRING:
+ strvalue(dst) = store_string(sc, strlength(dst), strvalue(dst), 0);
+ break;
+ case T_PORT:
+ /* XXX acquire reference */
+ assert (!"implemented");
+ break;
+ case T_FOREIGN_OBJECT:
+ /* XXX acquire reference */
+ assert (!"implemented");
+ break;
+ case T_VECTOR:
+ assert (!"vectors cannot be copied");
+ }
+}
+
+
+
+/* Tags are like property lists, but can be attached to arbitrary
+ * values. */
+
+static pointer
+mk_tagged_value(scheme *sc, pointer v, pointer tag_car, pointer tag_cdr)
+{
+ pointer r, t;
+
+ assert(! is_vector(v));
+
+ r = get_consecutive_cells(sc, 2);
+ if (r == sc->sink)
+ return sc->sink;
+
+ copy_value(sc, r, v);
+ typeflag(r) |= T_TAGGED;
+
+ t = r + 1;
+ typeflag(t) = T_PAIR;
+ car(t) = tag_car;
+ cdr(t) = tag_cdr;
+
+ return r;
+}
+
+static INLINE int
+has_tag(pointer v)
+{
+ return !! (typeflag(v) & T_TAGGED);
+}
+
+static INLINE pointer
+get_tag(scheme *sc, pointer v)
+{
+ if (has_tag(v))
+ return v + 1;
+ return sc->NIL;
+}
+
+
+
+/* Low-level allocator.
+ *
+ * Memory is allocated in segments. Every segment holds a fixed
+ * number of cells. Segments are linked into a list, sorted in
+ * reverse address order (i.e. those with a higher address first).
+ * This is used in the garbage collector to build the freelist in
+ * address order.
+ */
+
+struct cell_segment
+{
+ struct cell_segment *next;
+ void *alloc;
+ pointer cells;
+ size_t cells_len;
+};
+
+/* Allocate a new cell segment but do not make it available yet. */
+static int
+_alloc_cellseg(scheme *sc, size_t len, struct cell_segment **segment)
+{
+ int adj = ADJ;
+ void *cp;
+
+ if (adj < sizeof(struct cell))
+ adj = sizeof(struct cell);
+
+ /* The segment header is conveniently allocated with the cells. */
+ cp = sc->malloc(sizeof **segment + len * sizeof(struct cell) + adj);
+ if (cp == NULL)
+ return 1;
+
+ *segment = cp;
+ (*segment)->next = NULL;
+ (*segment)->alloc = cp;
+ cp = (void *) ((uintptr_t) cp + sizeof **segment);
+
+ /* adjust in TYPE_BITS-bit boundary */
+ if (((uintptr_t) cp) % adj != 0)
+ cp = (void *) (adj * ((uintptr_t) cp / adj + 1));
+
+ (*segment)->cells = cp;
+ (*segment)->cells_len = len;
+ return 0;
+}
+
+/* Deallocate a cell segment. Returns the next cell segment.
+ * Convenient for deallocation in a loop. */
+static struct cell_segment *
+_dealloc_cellseg(scheme *sc, struct cell_segment *segment)
+{
+
+ struct cell_segment *next;
+
+ if (segment == NULL)
+ return NULL;
+
+ next = segment->next;
+ sc->free(segment->alloc);
+ return next;
+}
+
+/* allocate new cell segment */
+static int alloc_cellseg(scheme *sc, int n) {
+ pointer last;
+ pointer p;
+ int k;
+
+ for (k = 0; k < n; k++) {
+ struct cell_segment *new, **s;
+ if (_alloc_cellseg(sc, CELL_SEGSIZE, &new)) {
+ return k;
+ }
+ /* insert new segment in reverse address order */
+ for (s = &sc->cell_segments;
+ *s && (uintptr_t) (*s)->alloc > (uintptr_t) new->alloc;
+ s = &(*s)->next) {
+ /* walk */
+ }
+ new->next = *s;
+ *s = new;
+
+ sc->fcells += new->cells_len;
+ last = new->cells + new->cells_len - 1;
+ for (p = new->cells; p <= last; p++) {
+ typeflag(p) = 0;
+ cdr(p) = p + 1;
+ car(p) = sc->NIL;
+ }
+ /* insert new cells in address order on free list */
+ if (sc->free_cell == sc->NIL || p < sc->free_cell) {
+ cdr(last) = sc->free_cell;
+ sc->free_cell = new->cells;
+ } else {
+ p = sc->free_cell;
+ while (cdr(p) != sc->NIL && (uintptr_t) new->cells > (uintptr_t) cdr(p))
+ p = cdr(p);
+ cdr(last) = cdr(p);
+ cdr(p) = new->cells;
+ }
+ }
+ return n;
+}
+
+
+
+/* Controlling the garbage collector.
+ *
+ * Every time a cell is allocated, the interpreter may run out of free
+ * cells and do a garbage collection. This is problematic because it
+ * might garbage collect objects that have been allocated, but are not
+ * yet made available to the interpreter.
+ *
+ * Previously, we would plug such newly allocated cells into the list
+ * of newly allocated objects rooted at car(sc->sink), but that
+ * requires allocating yet another cell increasing pressure on the
+ * memory management system.
+ *
+ * A faster alternative is to preallocate the cells needed for an
+ * operation and make sure the garbage collection is not run until all
+ * allocated objects are plugged in. This can be done with gc_disable
+ * and gc_enable.
+ */
+
+/* The garbage collector is enabled if the inhibit counter is
+ * zero. */
+#define GC_ENABLED 0
+
+/* For now we provide a way to disable this optimization for
+ * benchmarking and because it produces slightly smaller code. */
+#ifndef USE_GC_LOCKING
+# define USE_GC_LOCKING 1
+#endif
+
+/* To facilitate nested calls to gc_disable, functions that allocate
+ * more than one cell may define a macro, e.g. foo_allocates. This
+ * macro can be used to compute the amount of preallocation at the
+ * call site with the help of this macro. */
+#define gc_reservations(fn) fn ## _allocates
+
+#if USE_GC_LOCKING
+
+/* Report a shortage in reserved cells, and terminate the program. */
+static void
+gc_reservation_failure(struct scheme *sc)
+{
+#ifdef NDEBUG
+ fprintf(stderr,
+ "insufficient reservation\n");
+#else
+ fprintf(stderr,
+ "insufficient %s reservation in line %d\n",
+ sc->frame_freelist == sc->NIL ? "frame" : "cell",
+ sc->reserved_lineno);
+#endif
+ abort();
+}
+
+/* Disable the garbage collection and reserve the given number of
+ * cells. gc_disable may be nested, but the enclosing reservation
+ * must include the reservations of all nested calls. Note: You must
+ * re-enable the gc before calling Error_X. */
+static void
+_gc_disable(struct scheme *sc, size_t reserve, int lineno)
+{
+ if (sc->inhibit_gc == 0) {
+ reserve_cells(sc, (reserve));
+ sc->reserved_cells = (reserve);
+#ifdef NDEBUG
+ (void) lineno;
+#else
+ sc->reserved_lineno = lineno;
+#endif
+ } else if (sc->reserved_cells < (reserve))
+ gc_reservation_failure (sc);
+ sc->inhibit_gc += 1;
+}
+#define gc_disable(sc, reserve) \
+ do { \
+ if (sc->frame_freelist == sc->NIL) { \
+ if (gc_enabled(sc)) \
+ dump_stack_preallocate_frame(sc); \
+ else \
+ gc_reservation_failure(sc); \
+ } \
+ _gc_disable (sc, reserve, __LINE__); \
+ } while (0)
+
+/* Enable the garbage collector. */
+#define gc_enable(sc) \
+ do { \
+ assert(sc->inhibit_gc); \
+ sc->inhibit_gc -= 1; \
+ } while (0)
+
+/* Test whether the garbage collector is enabled. */
+#define gc_enabled(sc) \
+ (sc->inhibit_gc == GC_ENABLED)
+
+/* Consume a reserved cell. */
+#define gc_consume(sc) \
+ do { \
+ assert(! gc_enabled (sc)); \
+ if (sc->reserved_cells == 0) \
+ gc_reservation_failure (sc); \
+ sc->reserved_cells -= 1; \
+ } while (0)
+
+#else /* USE_GC_LOCKING */
+
+#define gc_reservation_failure(sc) (void) 0
+#define gc_disable(sc, reserve) \
+ do { \
+ if (sc->frame_freelist == sc->NIL) \
+ dump_stack_preallocate_frame(sc); \
+ } while (0)
+#define gc_enable(sc) (void) 0
+#define gc_enabled(sc) 1
+#define gc_consume(sc) (void) 0
+
+#endif /* USE_GC_LOCKING */
+
+static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
+ if (! gc_enabled (sc) || sc->free_cell != sc->NIL) {
+ pointer x = sc->free_cell;
+ if (! gc_enabled (sc))
+ gc_consume (sc);
+ sc->free_cell = cdr(x);
+ --sc->fcells;
+ return (x);
+ }
+ assert (gc_enabled (sc));
+ return _get_cell (sc, a, b);
+}
+
+
+/* get new cell. parameter a, b is marked by gc. */
+static pointer _get_cell(scheme *sc, pointer a, pointer b) {
+ pointer x;
+
+ if(sc->no_memory) {
+ return sc->sink;
+ }
+
+ assert (gc_enabled (sc));
+ if (sc->free_cell == sc->NIL) {
+ gc(sc,a, b);
+ if (sc->free_cell == sc->NIL) {
+ sc->no_memory=1;
+ return sc->sink;
+ }
+ }
+ x = sc->free_cell;
+ sc->free_cell = cdr(x);
+ --sc->fcells;
+ return (x);
+}
+
+/* make sure that there is a given number of cells free */
+static pointer reserve_cells(scheme *sc, int n) {
+ if(sc->no_memory) {
+ return sc->NIL;
+ }
+
+ /* Are there enough cells available? */
+ if (sc->fcells < n) {
+ /* If not, try gc'ing some */
+ gc(sc, sc->NIL, sc->NIL);
+ if (sc->fcells < n) {
+ /* If there still aren't, try getting more heap */
+ if (!alloc_cellseg(sc,1)) {
+ sc->no_memory=1;
+ return sc->NIL;
+ }
+ }
+ if (sc->fcells < n) {
+ /* If all fail, report failure */
+ sc->no_memory=1;
+ return sc->NIL;
+ }
+ }
+ return (sc->T);
+}
+
+static pointer get_consecutive_cells(scheme *sc, int n) {
+ pointer x;
+
+ if(sc->no_memory) { return sc->sink; }
+
+ /* Are there any cells available? */
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If not, try gc'ing some */
+ gc(sc, sc->NIL, sc->NIL);
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If there still aren't, try getting more heap */
+ if (!alloc_cellseg(sc,1))
+ {
+ sc->no_memory=1;
+ return sc->sink;
+ }
+
+ x=find_consecutive_cells(sc,n);
+ if (x != sc->NIL) { return x; }
+
+ /* If all fail, report failure */
+ sc->no_memory=1;
+ return sc->sink;
+}
+
+static int count_consecutive_cells(pointer x, int needed) {
+ int n=1;
+ while(cdr(x)==x+1) {
+ x=cdr(x);
+ n++;
+ if(n>needed) return n;
+ }
+ return n;
+}
+
+static pointer find_consecutive_cells(scheme *sc, int n) {
+ pointer *pp;
+ int cnt;
+
+ pp=&sc->free_cell;
+ while(*pp!=sc->NIL) {
+ cnt=count_consecutive_cells(*pp,n);
+ if(cnt>=n) {
+ pointer x=*pp;
+ *pp=cdr(*pp+n-1);
+ sc->fcells -= n;
+ return x;
+ }
+ pp=&cdr(*pp+cnt-1);
+ }
+ return sc->NIL;
+}
+
+/* Free a cell. This is dangerous. Only free cells that are not
+ * referenced. */
+static INLINE void
+free_cell(scheme *sc, pointer a)
+{
+ cdr(a) = sc->free_cell;
+ sc->free_cell = a;
+ sc->fcells += 1;
+}
+
+/* Free a cell and retrieve its content. This is dangerous. Only
+ * free cells that are not referenced. */
+static INLINE void
+free_cons(scheme *sc, pointer a, pointer *r_car, pointer *r_cdr)
+{
+ *r_car = car(a);
+ *r_cdr = cdr(a);
+ free_cell(sc, a);
+}
+
+/* To retain recent allocs before interpreter knows about them -
+ Tehom */
+
+static void push_recent_alloc(scheme *sc, pointer recent, pointer extra)
+{
+ pointer holder = get_cell_x(sc, recent, extra);
+ typeflag(holder) = T_PAIR | T_IMMUTABLE;
+ car(holder) = recent;
+ cdr(holder) = car(sc->sink);
+ car(sc->sink) = holder;
+}
+
+static INLINE void ok_to_freely_gc(scheme *sc)
+{
+ pointer a = car(sc->sink), next;
+ car(sc->sink) = sc->NIL;
+ while (a != sc->NIL)
+ {
+ next = cdr(a);
+ free_cell(sc, a);
+ a = next;
+ }
+}
+
+static pointer get_cell(scheme *sc, pointer a, pointer b)
+{
+ pointer cell = get_cell_x(sc, a, b);
+ /* For right now, include "a" and "b" in "cell" so that gc doesn't
+ think they are garbage. */
+ /* Tentatively record it as a pair so gc understands it. */
+ typeflag(cell) = T_PAIR;
+ car(cell) = a;
+ cdr(cell) = b;
+ if (gc_enabled (sc))
+ push_recent_alloc(sc, cell, sc->NIL);
+ return cell;
+}
+
+static pointer get_vector_object(scheme *sc, int len, pointer init)
+{
+ pointer cells = get_consecutive_cells(sc, vector_size(len));
+ int i;
+ int alloc_len = 1 + 3 * (vector_size(len) - 1);
+ if(sc->no_memory) { return sc->sink; }
+ /* Record it as a vector so that gc understands it. */
+ typeflag(cells) = (T_VECTOR | T_ATOM | T_FINALIZE);
+ vector_length(cells) = len;
+ fill_vector(cells,init);
+
+ /* Initialize the unused slots at the end. */
+ assert (alloc_len - len < 3);
+ for (i = len; i < alloc_len; i++)
+ cells->_object._vector._elements[i] = sc->NIL;
+
+ if (gc_enabled (sc))
+ push_recent_alloc(sc, cells, sc->NIL);
+ return cells;
+}
+
+/* Medium level cell allocation */
+
+/* get new cons cell */
+pointer _cons(scheme *sc, pointer a, pointer b, int immutable) {
+ pointer x = get_cell(sc,a, b);
+
+ typeflag(x) = T_PAIR;
+ if(immutable) {
+ setimmutable(x);
+ }
+ car(x) = a;
+ cdr(x) = b;
+ return (x);
+}
+
+
+/* ========== oblist implementation ========== */
+
+#ifndef USE_OBJECT_LIST
+
+static int hash_fn(const char *key, int table_size);
+
+static pointer oblist_initial_value(scheme *sc)
+{
+ /* There are about 768 symbols used after loading the
+ * interpreter. */
+ return mk_vector(sc, 1009);
+}
+
+/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not
+ * exist. In that case, SLOT points to the point where the new symbol
+ * is to be inserted. */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
+{
+ int location;
+ pointer x;
+ char *s;
+ int d;
+
+ location = hash_fn(name, vector_length(sc->oblist));
+ for (*slot = vector_elem_slot(sc->oblist, location), x = **slot;
+ x != sc->NIL; *slot = &cdr(x), x = **slot) {
+ s = symname(car(x));
+ /* case-insensitive, per R5RS section 2. */
+ d = stricmp(name, s);
+ if (d == 0)
+ return car(x); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
+ }
+ return sc->NIL;
+}
+
+static pointer oblist_all_symbols(scheme *sc)
+{
+ int i;
+ pointer x;
+ pointer ob_list = sc->NIL;
+
+ for (i = 0; i < vector_length(sc->oblist); i++) {
+ for (x = vector_elem(sc->oblist, i); x != sc->NIL; x = cdr(x)) {
+ ob_list = cons(sc, x, ob_list);
+ }
+ }
+ return ob_list;
+}
+
+#else
+
+static pointer oblist_initial_value(scheme *sc)
+{
+ return sc->NIL;
+}
+
+/* Lookup the symbol NAME. Returns the symbol, or NIL if it does not
+ * exist. In that case, SLOT points to the point where the new symbol
+ * is to be inserted. */
+static INLINE pointer
+oblist_find_by_name(scheme *sc, const char *name, pointer **slot)
+{
+ pointer x;
+ char *s;
+ int d;
+
+ for (*slot = &sc->oblist, x = **slot; x != sc->NIL; *slot = &cdr(x), x = **slot) {
+ s = symname(car(x));
+ /* case-insensitive, per R5RS section 2. */
+ d = stricmp(name, s);
+ if (d == 0)
+ return car(x); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
+ }
+ return sc->NIL;
+}
+
+static pointer oblist_all_symbols(scheme *sc)
+{
+ return sc->oblist;
+}
+
+#endif
+
+/* Add a new symbol NAME at SLOT. SLOT must be obtained using
+ * oblist_find_by_name, and no insertion must be done between
+ * obtaining the SLOT and calling this function. Returns the new
+ * symbol. */
+static pointer oblist_add_by_name(scheme *sc, const char *name, pointer *slot)
+{
+#define oblist_add_by_name_allocates 3
+ pointer x;
+
+ gc_disable(sc, gc_reservations (oblist_add_by_name));
+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
+ typeflag(x) = T_SYMBOL;
+ setimmutable(car(x));
+ *slot = immutable_cons(sc, x, *slot);
+ gc_enable(sc);
+ return x;
+}
+
+
+
+static pointer mk_port(scheme *sc, port *p) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = T_PORT|T_ATOM|T_FINALIZE;
+ x->_object._port=p;
+ return (x);
+}
+
+pointer mk_foreign_func(scheme *sc, foreign_func f) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_FOREIGN | T_ATOM);
+ x->_object._ff=f;
+ return (x);
+}
+
+pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_FOREIGN_OBJECT | T_ATOM | T_FINALIZE);
+ x->_object._foreign_object._vtable=vtable;
+ x->_object._foreign_object._data = data;
+ return (x);
+}
+
+INTERFACE pointer mk_character(scheme *sc, int c) {
+ pointer x = get_cell(sc,sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_CHARACTER | T_ATOM);
+ ivalue_unchecked(x)= c;
+ set_num_integer(x);
+ return (x);
+}
+
+
+
+#if USE_SMALL_INTEGERS
+
+static const struct cell small_integers[] = {
+#define DEFINE_INTEGER(n) { T_NUMBER | T_ATOM | MARK, {{ 1, {n}}}},
+#include "small-integers.h"
+#undef DEFINE_INTEGER
+ {0}
+};
+
+#define MAX_SMALL_INTEGER (sizeof small_integers / sizeof *small_integers - 1)
+
+static INLINE pointer
+mk_small_integer(scheme *sc, long n)
+{
+#define mk_small_integer_allocates 0
+ (void) sc;
+ assert(0 <= n && n < MAX_SMALL_INTEGER);
+ return (pointer) &small_integers[n];
+}
+#else
+
+#define mk_small_integer_allocates 1
+#define mk_small_integer mk_integer
+
+#endif
+
+/* get number atom (integer) */
+INTERFACE pointer mk_integer(scheme *sc, long n) {
+ pointer x;
+
+#if USE_SMALL_INTEGERS
+ if (0 <= n && n < MAX_SMALL_INTEGER)
+ return mk_small_integer(sc, n);
+#endif
+
+ x = get_cell(sc,sc->NIL, sc->NIL);
+ typeflag(x) = (T_NUMBER | T_ATOM);
+ ivalue_unchecked(x)= n;
+ set_num_integer(x);
+ return (x);
+}
+
+
+
+INTERFACE pointer mk_real(scheme *sc, double n) {
+ pointer x = get_cell(sc,sc->NIL, sc->NIL);
+
+ typeflag(x) = (T_NUMBER | T_ATOM);
+ rvalue_unchecked(x)= n;
+ set_num_real(x);
+ return (x);
+}
+
+static pointer mk_number(scheme *sc, num n) {
+ if(n.is_fixnum) {
+ return mk_integer(sc,n.value.ivalue);
+ } else {
+ return mk_real(sc,n.value.rvalue);
+ }
+}
+
+/* allocate name to string area */
+static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
+ char *q;
+
+ q=(char*)sc->malloc(len_str+1);
+ if(q==0) {
+ sc->no_memory=1;
+ return sc->strbuff;
+ }
+ if(str!=0) {
+ memcpy (q, str, len_str);
+ q[len_str]=0;
+ } else {
+ memset(q, fill, len_str);
+ q[len_str]=0;
+ }
+ return (q);
+}
+
+/* get new string */
+INTERFACE pointer mk_string(scheme *sc, const char *str) {
+ return mk_counted_string(sc,str,strlen(str));
+}
+
+INTERFACE pointer mk_counted_string(scheme *sc, const char *str, int len) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+ typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
+ strvalue(x) = store_string(sc,len,str,0);
+ strlength(x) = len;
+ return (x);
+}
+
+INTERFACE pointer mk_empty_string(scheme *sc, int len, char fill) {
+ pointer x = get_cell(sc, sc->NIL, sc->NIL);
+ typeflag(x) = (T_STRING | T_ATOM | T_FINALIZE);
+ strvalue(x) = store_string(sc,len,0,fill);
+ strlength(x) = len;
+ return (x);
+}
+
+INTERFACE static pointer mk_vector(scheme *sc, int len)
+{ return get_vector_object(sc,len,sc->NIL); }
+
+INTERFACE static void fill_vector(pointer vec, pointer obj) {
+ size_t i;
+ assert (is_vector (vec));
+ for(i = 0; i < vector_length(vec); i++) {
+ vec->_object._vector._elements[i] = obj;
+ }
+}
+
+INTERFACE static pointer *vector_elem_slot(pointer vec, int ielem) {
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ return &vec->_object._vector._elements[ielem];
+}
+
+INTERFACE static pointer vector_elem(pointer vec, int ielem) {
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ return vec->_object._vector._elements[ielem];
+}
+
+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
+ assert (is_vector (vec));
+ assert (ielem < vector_length(vec));
+ vec->_object._vector._elements[ielem] = a;
+ return a;
+}
+
+/* get new symbol */
+INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
+#define mk_symbol_allocates oblist_add_by_name_allocates
+ pointer x;
+ pointer *slot;
+
+ /* first check oblist */
+ x = oblist_find_by_name(sc, name, &slot);
+ if (x != sc->NIL) {
+ return (x);
+ } else {
+ x = oblist_add_by_name(sc, name, slot);
+ return (x);
+ }
+}
+
+INTERFACE pointer gensym(scheme *sc) {
+ pointer x;
+ pointer *slot;
+ char name[40];
+
+ for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
+ snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
+
+ /* first check oblist */
+ x = oblist_find_by_name(sc, name, &slot);
+
+ if (x != sc->NIL) {
+ continue;
+ } else {
+ x = oblist_add_by_name(sc, name, slot);
+ return (x);
+ }
+ }
+
+ return sc->NIL;
+}
+
+/* double the size of the string buffer */
+static int expand_strbuff(scheme *sc) {
+ size_t new_size = sc->strbuff_size * 2;
+ char *new_buffer = sc->malloc(new_size);
+ if (new_buffer == 0) {
+ sc->no_memory = 1;
+ return 1;
+ }
+ memcpy(new_buffer, sc->strbuff, sc->strbuff_size);
+ sc->free(sc->strbuff);
+ sc->strbuff = new_buffer;
+ sc->strbuff_size = new_size;
+ return 0;
+}
+
+/* make symbol or number atom from string */
+static pointer mk_atom(scheme *sc, char *q) {
+ char c, *p;
+ int has_dec_point=0;
+ int has_fp_exp = 0;
+
+#if USE_COLON_HOOK
+ char *next;
+ next = p = q;
+ while ((next = strstr(next, "::")) != 0) {
+ /* Keep looking for the last occurrence. */
+ p = next;
+ next = next + 2;
+ }
+
+ if (p != q) {
+ *p=0;
+ return cons(sc, sc->COLON_HOOK,
+ cons(sc,
+ cons(sc,
+ sc->QUOTE,
+ cons(sc, mk_symbol(sc, strlwr(p + 2)),
+ sc->NIL)),
+ cons(sc, mk_atom(sc, q), sc->NIL)));
+ }
+#endif
+
+ p = q;
+ c = *p++;
+ if ((c == '+') || (c == '-')) {
+ c = *p++;
+ if (c == '.') {
+ has_dec_point=1;
+ c = *p++;
+ }
+ if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ } else if (c == '.') {
+ has_dec_point=1;
+ c = *p++;
+ if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ } else if (!isdigit(c)) {
+ return (mk_symbol(sc, strlwr(q)));
+ }
+
+ for ( ; (c = *p) != 0; ++p) {
+ if (!isdigit(c)) {
+ if(c=='.') {
+ if(!has_dec_point) {
+ has_dec_point=1;
+ continue;
+ }
+ }
+ else if ((c == 'e') || (c == 'E')) {
+ if(!has_fp_exp) {
+ has_dec_point = 1; /* decimal point illegal
+ from now on */
+ p++;
+ if ((*p == '-') || (*p == '+') || isdigit(*p)) {
+ continue;
+ }
+ }
+ }
+ return (mk_symbol(sc, strlwr(q)));
+ }
+ }
+ if(has_dec_point) {
+ return mk_real(sc,atof(q));
+ }
+ return (mk_integer(sc, atol(q)));
+}
+
+/* make constant */
+static pointer mk_sharp_const(scheme *sc, char *name) {
+ long x;
+ char tmp[STRBUFFSIZE];
+
+ if (!strcmp(name, "t"))
+ return (sc->T);
+ else if (!strcmp(name, "f"))
+ return (sc->F);
+ else if (*name == 'o') {/* #o (octal) */
+ snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
+ sscanf(tmp, "%lo", (long unsigned *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'd') { /* #d (decimal) */
+ sscanf(name+1, "%ld", (long int *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'x') { /* #x (hex) */
+ snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
+ sscanf(tmp, "%lx", (long unsigned *)&x);
+ return (mk_integer(sc, x));
+ } else if (*name == 'b') { /* #b (binary) */
+ x = binary_decode(name+1);
+ return (mk_integer(sc, x));
+ } else if (*name == '\\') { /* #\w (character) */
+ int c=0;
+ if(stricmp(name+1,"space")==0) {
+ c=' ';
+ } else if(stricmp(name+1,"newline")==0) {
+ c='\n';
+ } else if(stricmp(name+1,"return")==0) {
+ c='\r';
+ } else if(stricmp(name+1,"tab")==0) {
+ c='\t';
+ } else if(name[1]=='x' && name[2]!=0) {
+ int c1=0;
+ if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
+ c=c1;
+ } else {
+ return sc->NIL;
+ }
+#if USE_ASCII_NAMES
+ } else if(is_ascii_name(name+1,&c)) {
+ /* nothing */
+#endif
+ } else if(name[2]==0) {
+ c=name[1];
+ } else {
+ return sc->NIL;
+ }
+ return mk_character(sc,c);
+ } else
+ return (sc->NIL);
+}
+
+/* ========== garbage collector ========== */
+
+const int frame_length;
+static void dump_stack_deallocate_frame(scheme *sc, pointer frame);
+
+/*--
+ * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,
+ * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm,
+ * for marking.
+ */
+static void mark(pointer a) {
+ pointer t, q, p;
+
+ t = (pointer) 0;
+ p = a;
+E2: if (! is_mark(p))
+ setmark(p);
+ if (is_vector(p) || is_frame(p)) {
+ int i;
+ int len = is_vector(p) ? vector_length(p) : frame_length;
+ for (i = 0; i < len; i++) {
+ mark(p->_object._vector._elements[i]);
+ }
+ }
+#if SHOW_ERROR_LINE
+ else if (is_port(p)) {
+ port *pt = p->_object._port;
+ mark(pt->curr_line);
+ mark(pt->filename);
+ }
+#endif
+ /* Mark tag if p has one. */
+ if (has_tag(p))
+ mark(p + 1);
+ if (is_atom(p))
+ goto E6;
+ /* E4: down car */
+ q = car(p);
+ if (q && !is_mark(q)) {
+ setatom(p); /* a note that we have moved car */
+ car(p) = t;
+ t = p;
+ p = q;
+ goto E2;
+ }
+E5: q = cdr(p); /* down cdr */
+ if (q && !is_mark(q)) {
+ cdr(p) = t;
+ t = p;
+ p = q;
+ goto E2;
+ }
+E6: /* up. Undo the link switching from steps E4 and E5. */
+ if (!t)
+ return;
+ q = t;
+ if (is_atom(q)) {
+ clratom(q);
+ t = car(q);
+ car(q) = p;
+ p = q;
+ goto E5;
+ } else {
+ t = cdr(q);
+ cdr(q) = p;
+ p = q;
+ goto E6;
+ }
+}
+
+/* garbage collection. parameter a, b is marked. */
+static void gc(scheme *sc, pointer a, pointer b) {
+ pointer p;
+ struct cell_segment *s;
+ int i;
+
+ assert (gc_enabled (sc));
+
+ if(sc->gc_verbose) {
+ putstr(sc, "gc...");
+ }
+
+ /* mark system globals */
+ mark(sc->oblist);
+ mark(sc->global_env);
+
+ /* mark current registers */
+ mark(sc->args);
+ mark(sc->envir);
+ mark(sc->code);
+ history_mark(sc);
+ dump_stack_mark(sc);
+ mark(sc->value);
+ mark(sc->inport);
+ mark(sc->save_inport);
+ mark(sc->outport);
+ mark(sc->loadport);
+ for (i = 0; i <= sc->file_i; i++) {
+ mark(sc->load_stack[i].filename);
+ mark(sc->load_stack[i].curr_line);
+ }
+
+ /* Mark recent objects the interpreter doesn't know about yet. */
+ mark(car(sc->sink));
+ /* Mark any older stuff above nested C calls */
+ mark(sc->c_nest);
+
+ /* mark variables a, b */
+ mark(a);
+ mark(b);
+
+ /* garbage collect */
+ clrmark(sc->NIL);
+ sc->fcells = 0;
+ sc->free_cell = sc->NIL;
+ /* free-list is kept sorted by address so as to maintain consecutive
+ ranges, if possible, for use with vectors. Here we scan the cells
+ (which are also kept sorted by address) downwards to build the
+ free-list in sorted order.
+ */
+ for (s = sc->cell_segments; s; s = s->next) {
+ p = s->cells + s->cells_len;
+ while (--p >= s->cells) {
+ if ((typeflag(p) & 1) == 0)
+ /* All types have the LSB set. This is not a typeflag. */
+ continue;
+ if (is_mark(p)) {
+ clrmark(p);
+ } else {
+ /* reclaim cell */
+ if ((typeflag(p) & T_FINALIZE) == 0
+ || finalize_cell(sc, p)) {
+ /* Reclaim cell. */
+ ++sc->fcells;
+ typeflag(p) = 0;
+ car(p) = sc->NIL;
+ cdr(p) = sc->free_cell;
+ sc->free_cell = p;
+ }
+ }
+ }
+ }
+
+ if (sc->gc_verbose) {
+ char msg[80];
+ snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
+ putstr(sc,msg);
+ }
+
+ /* if only a few recovered, get more to avoid fruitless gc's */
+ if (sc->fcells < CELL_MINRECOVER
+ && alloc_cellseg(sc, 1) == 0)
+ sc->no_memory = 1;
+}
+
+/* Finalize A. Returns true if a can be added to the list of free
+ * cells. */
+static int
+finalize_cell(scheme *sc, pointer a)
+{
+ switch (type(a)) {
+ case T_STRING:
+ sc->free(strvalue(a));
+ break;
+
+ case T_PORT:
+ if(a->_object._port->kind&port_file
+ && a->_object._port->rep.stdio.closeit) {
+ port_close(sc,a,port_input|port_output);
+ } else if (a->_object._port->kind & port_srfi6) {
+ sc->free(a->_object._port->rep.string.start);
+ }
+ sc->free(a->_object._port);
+ break;
+
+ case T_FOREIGN_OBJECT:
+ a->_object._foreign_object._vtable->finalize(sc, a->_object._foreign_object._data);
+ break;
+
+ case T_VECTOR:
+ do {
+ int i;
+ for (i = vector_size(vector_length(a)) - 1; i > 0; i--) {
+ pointer p = a + i;
+ typeflag(p) = 0;
+ car(p) = sc->NIL;
+ cdr(p) = sc->free_cell;
+ sc->free_cell = p;
+ sc->fcells += 1;
+ }
+ } while (0);
+ break;
+
+ case T_FRAME:
+ dump_stack_deallocate_frame(sc, a);
+ return 0; /* Do not free cell. */
+ }
+
+ return 1; /* Free cell. */
+}
+
+#if SHOW_ERROR_LINE
+static void
+port_clear_location (scheme *sc, port *p)
+{
+ p->curr_line = sc->NIL;
+ p->filename = sc->NIL;
+}
+
+static void
+port_increment_current_line (scheme *sc, port *p, long delta)
+{
+ if (delta == 0)
+ return;
+
+ p->curr_line =
+ mk_integer(sc, ivalue_unchecked(p->curr_line) + delta);
+}
+
+static void
+port_init_location (scheme *sc, port *p, pointer name)
+{
+ p->curr_line = mk_integer(sc, 0);
+ p->filename = name ? name : mk_string(sc, "<unknown>");
+}
+
+#else
+
+static void
+port_clear_location (scheme *sc, port *p)
+{
+}
+
+static void
+port_increment_current_line (scheme *sc, port *p, long delta)
+{
+}
+
+static void
+port_init_location (scheme *sc, port *p, pointer name)
+{
+}
+
+#endif
+
+/* ========== Routines for Reading ========== */
+
+static int file_push(scheme *sc, pointer fname) {
+ FILE *fin = NULL;
+
+ if (sc->file_i == MAXFIL-1)
+ return 0;
+ fin = fopen(string_value(fname), "r");
+ if(fin!=0) {
+ sc->file_i++;
+ sc->load_stack[sc->file_i].kind=port_file|port_input;
+ sc->load_stack[sc->file_i].rep.stdio.file=fin;
+ sc->load_stack[sc->file_i].rep.stdio.closeit=1;
+ sc->nesting_stack[sc->file_i]=0;
+ sc->loadport->_object._port=sc->load_stack+sc->file_i;
+ port_init_location(sc, &sc->load_stack[sc->file_i], fname);
+ }
+ return fin!=0;
+}
+
+static void file_pop(scheme *sc) {
+ if(sc->file_i != 0) {
+ sc->nesting=sc->nesting_stack[sc->file_i];
+ port_close(sc,sc->loadport,port_input);
+ port_clear_location(sc, &sc->load_stack[sc->file_i]);
+ sc->file_i--;
+ sc->loadport->_object._port=sc->load_stack+sc->file_i;
+ }
+}
+
+static int file_interactive(scheme *sc) {
+ return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
+ && sc->inport->_object._port->kind&port_file;
+}
+
+static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
+ FILE *f;
+ char *rw;
+ port *pt;
+ if(prop==(port_input|port_output)) {
+ rw="a+";
+ } else if(prop==port_output) {
+ rw="w";
+ } else {
+ rw="r";
+ }
+ f=fopen(fn,rw);
+ if(f==0) {
+ return 0;
+ }
+ pt=port_rep_from_file(sc,f,prop);
+ pt->rep.stdio.closeit=1;
+ port_init_location(sc, pt, mk_string(sc, fn));
+ return pt;
+}
+
+static pointer port_from_filename(scheme *sc, const char *fn, int prop) {
+ port *pt;
+ pt=port_rep_from_filename(sc,fn,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static port *port_rep_from_file(scheme *sc, FILE *f, int prop)
+{
+ port *pt;
+
+ pt = (port *)sc->malloc(sizeof *pt);
+ if (pt == NULL) {
+ return NULL;
+ }
+ pt->kind = port_file | prop;
+ pt->rep.stdio.file = f;
+ pt->rep.stdio.closeit = 0;
+ port_init_location(sc, pt, NULL);
+ return pt;
+}
+
+static pointer port_from_file(scheme *sc, FILE *f, int prop) {
+ port *pt;
+ pt=port_rep_from_file(sc,f,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static port *port_rep_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
+ port *pt;
+ pt=(port*)sc->malloc(sizeof(port));
+ if(pt==0) {
+ return 0;
+ }
+ pt->kind=port_string|prop;
+ pt->rep.string.start=start;
+ pt->rep.string.curr=start;
+ pt->rep.string.past_the_end=past_the_end;
+ port_init_location(sc, pt, NULL);
+ return pt;
+}
+
+static pointer port_from_string(scheme *sc, char *start, char *past_the_end, int prop) {
+ port *pt;
+ pt=port_rep_from_string(sc,start,past_the_end,prop);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+#define BLOCK_SIZE 256
+
+static port *port_rep_from_scratch(scheme *sc) {
+ port *pt;
+ char *start;
+ pt=(port*)sc->malloc(sizeof(port));
+ if(pt==0) {
+ return 0;
+ }
+ start=sc->malloc(BLOCK_SIZE);
+ if(start==0) {
+ return 0;
+ }
+ memset(start,' ',BLOCK_SIZE-1);
+ start[BLOCK_SIZE-1]='\0';
+ pt->kind=port_string|port_output|port_srfi6;
+ pt->rep.string.start=start;
+ pt->rep.string.curr=start;
+ pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
+ port_init_location(sc, pt, NULL);
+ return pt;
+}
+
+static pointer port_from_scratch(scheme *sc) {
+ port *pt;
+ pt=port_rep_from_scratch(sc);
+ if(pt==0) {
+ return sc->NIL;
+ }
+ return mk_port(sc,pt);
+}
+
+static void port_close(scheme *sc, pointer p, int flag) {
+ port *pt=p->_object._port;
+ pt->kind&=~flag;
+ if((pt->kind & (port_input|port_output))==0) {
+ /* Cleanup is here so (close-*-port) functions could work too */
+ port_clear_location(sc, pt);
+ if(pt->kind&port_file) {
+ fclose(pt->rep.stdio.file);
+ }
+ pt->kind=port_free;
+ }
+}
+
+/* get new character from input file */
+static int inchar(scheme *sc) {
+ int c;
+ port *pt;
+
+ pt = sc->inport->_object._port;
+ if(pt->kind & port_saw_EOF)
+ { return EOF; }
+ c = basic_inchar(pt);
+ if(c == EOF && sc->inport == sc->loadport) {
+ /* Instead, set port_saw_EOF */
+ pt->kind |= port_saw_EOF;
+
+ /* file_pop(sc); */
+ return EOF;
+ /* NOTREACHED */
+ }
+ return c;
+}
+
+static int basic_inchar(port *pt) {
+ if(pt->kind & port_file) {
+ return fgetc(pt->rep.stdio.file);
+ } else {
+ if(*pt->rep.string.curr == 0 ||
+ pt->rep.string.curr == pt->rep.string.past_the_end) {
+ return EOF;
+ } else {
+ return *pt->rep.string.curr++;
+ }
+ }
+}
+
+/* back character to input buffer */
+static void backchar(scheme *sc, int c) {
+ port *pt;
+ if(c==EOF) return;
+ pt=sc->inport->_object._port;
+ if(pt->kind&port_file) {
+ ungetc(c,pt->rep.stdio.file);
+ } else {
+ if(pt->rep.string.curr!=pt->rep.string.start) {
+ --pt->rep.string.curr;
+ }
+ }
+}
+
+static int realloc_port_string(scheme *sc, port *p)
+{
+ char *start=p->rep.string.start;
+ size_t old_size = p->rep.string.past_the_end - start;
+ size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
+ char *str=sc->malloc(new_size);
+ if(str) {
+ memset(str,' ',new_size-1);
+ str[new_size-1]='\0';
+ memcpy(str, start, old_size);
+ p->rep.string.start=str;
+ p->rep.string.past_the_end=str+new_size-1;
+ p->rep.string.curr-=start-str;
+ sc->free(start);
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+INTERFACE void putstr(scheme *sc, const char *s) {
+ port *pt=sc->outport->_object._port;
+ if(pt->kind&port_file) {
+ fputs(s,pt->rep.stdio.file);
+ } else {
+ for(;*s;s++) {
+ if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
+ *pt->rep.string.curr++=*s;
+ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
+ *pt->rep.string.curr++=*s;
+ }
+ }
+ }
+}
+
+static void putchars(scheme *sc, const char *s, int len) {
+ port *pt=sc->outport->_object._port;
+ if(pt->kind&port_file) {
+ fwrite(s,1,len,pt->rep.stdio.file);
+ } else {
+ for(;len;len--) {
+ if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
+ *pt->rep.string.curr++=*s++;
+ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
+ *pt->rep.string.curr++=*s++;
+ }
+ }
+ }
+}
+
+INTERFACE void putcharacter(scheme *sc, int c) {
+ port *pt=sc->outport->_object._port;
+ if(pt->kind&port_file) {
+ fputc(c,pt->rep.stdio.file);
+ } else {
+ if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
+ *pt->rep.string.curr++=c;
+ } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
+ *pt->rep.string.curr++=c;
+ }
+ }
+}
+
+/* read characters up to delimiter, but cater to character constants */
+static char *readstr_upto(scheme *sc, char *delim) {
+ char *p = sc->strbuff;
+
+ while ((p - sc->strbuff < sc->strbuff_size) &&
+ !is_one_of(delim, (*p++ = inchar(sc))));
+
+ if(p == sc->strbuff+2 && p[-2] == '\\') {
+ *p=0;
+ } else {
+ backchar(sc,p[-1]);
+ *--p = '\0';
+ }
+ return sc->strbuff;
+}
+
+/* read string expression "xxx...xxx" */
+static pointer readstrexp(scheme *sc) {
+ char *p = sc->strbuff;
+ int c;
+ int c1=0;
+ enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;
+
+ for (;;) {
+ c=inchar(sc);
+ if(c == EOF) {
+ return sc->F;
+ }
+ if(p-sc->strbuff > (sc->strbuff_size)-1) {
+ ptrdiff_t offset = p - sc->strbuff;
+ if (expand_strbuff(sc) != 0) {
+ return sc->F;
+ }
+ p = sc->strbuff + offset;
+ }
+ switch(state) {
+ case st_ok:
+ switch(c) {
+ case '\\':
+ state=st_bsl;
+ break;
+ case '"':
+ *p=0;
+ return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
+ default:
+ *p++=c;
+ break;
+ }
+ break;
+ case st_bsl:
+ switch(c) {
+ case '0':
+ case '1':
+ case '2':
+ case '3':
+ case '4':
+ case '5':
+ case '6':
+ case '7':
+ state=st_oct1;
+ c1=c-'0';
+ break;
+ case 'x':
+ case 'X':
+ state=st_x1;
+ c1=0;
+ break;
+ case 'n':
+ *p++='\n';
+ state=st_ok;
+ break;
+ case 't':
+ *p++='\t';
+ state=st_ok;
+ break;
+ case 'r':
+ *p++='\r';
+ state=st_ok;
+ break;
+ case '"':
+ *p++='"';
+ state=st_ok;
+ break;
+ default:
+ *p++=c;
+ state=st_ok;
+ break;
+ }
+ break;
+ case st_x1:
+ case st_x2:
+ c=toupper(c);
+ if(c>='0' && c<='F') {
+ if(c<='9') {
+ c1=(c1<<4)+c-'0';
+ } else {
+ c1=(c1<<4)+c-'A'+10;
+ }
+ if(state==st_x1) {
+ state=st_x2;
+ } else {
+ *p++=c1;
+ state=st_ok;
+ }
+ } else {
+ return sc->F;
+ }
+ break;
+ case st_oct1:
+ case st_oct2:
+ if (c < '0' || c > '7')
+ {
+ *p++=c1;
+ backchar(sc, c);
+ state=st_ok;
+ }
+ else
+ {
+ if (state==st_oct2 && c1 >= 32)
+ return sc->F;
+
+ c1=(c1<<3)+(c-'0');
+
+ if (state == st_oct1)
+ state=st_oct2;
+ else
+ {
+ *p++=c1;
+ state=st_ok;
+ }
+ }
+ break;
+
+ }
+ }
+}
+
+/* check c is in chars */
+static INLINE int is_one_of(char *s, int c) {
+ if(c==EOF) return 1;
+ while (*s)
+ if (*s++ == c)
+ return (1);
+ return (0);
+}
+
+/* skip white characters */
+static INLINE int skipspace(scheme *sc) {
+ int c = 0, curr_line = 0;
+
+ do {
+ c=inchar(sc);
+#if SHOW_ERROR_LINE
+ if(c=='\n')
+ curr_line++;
+#endif
+ } while (isspace(c));
+
+ /* record it */
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], curr_line);
+
+ if(c!=EOF) {
+ backchar(sc,c);
+ return 1;
+ }
+ else
+ { return EOF; }
+}
+
+/* get token */
+static int token(scheme *sc) {
+ int c;
+ c = skipspace(sc);
+ if(c == EOF) { return (TOK_EOF); }
+ switch (c=inchar(sc)) {
+ case EOF:
+ return (TOK_EOF);
+ case '(':
+ return (TOK_LPAREN);
+ case ')':
+ return (TOK_RPAREN);
+ case '.':
+ c=inchar(sc);
+ if(is_one_of(" \n\t",c)) {
+ return (TOK_DOT);
+ } else {
+ backchar(sc,c);
+ backchar(sc,'.');
+ return TOK_ATOM;
+ }
+ case '\'':
+ return (TOK_QUOTE);
+ case ';':
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+
+ if(c == '\n')
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
+ case '"':
+ return (TOK_DQUOTE);
+ case BACKQUOTE:
+ return (TOK_BQUOTE);
+ case ',':
+ if ((c=inchar(sc)) == '@') {
+ return (TOK_ATMARK);
+ } else {
+ backchar(sc,c);
+ return (TOK_COMMA);
+ }
+ case '#':
+ c=inchar(sc);
+ if (c == '(') {
+ return (TOK_VEC);
+ } else if(c == '!') {
+ while ((c=inchar(sc)) != '\n' && c!=EOF)
+ ;
+
+ if(c == '\n')
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
+
+ if(c == EOF)
+ { return (TOK_EOF); }
+ else
+ { return (token(sc));}
+ } else {
+ backchar(sc,c);
+ if(is_one_of(" tfodxb\\",c)) {
+ return TOK_SHARP_CONST;
+ } else {
+ return (TOK_SHARP);
+ }
+ }
+ default:
+ backchar(sc,c);
+ return (TOK_ATOM);
+ }
+}
+
+/* ========== Routines for Printing ========== */
+#define ok_abbrev(x) (is_pair(x) && cdr(x) == sc->NIL)
+
+static void printslashstring(scheme *sc, char *p, int len) {
+ int i;
+ unsigned char *s=(unsigned char*)p;
+ putcharacter(sc,'"');
+ for ( i=0; i<len; i++) {
+ if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
+ putcharacter(sc,'\\');
+ switch(*s) {
+ case '"':
+ putcharacter(sc,'"');
+ break;
+ case '\n':
+ putcharacter(sc,'n');
+ break;
+ case '\t':
+ putcharacter(sc,'t');
+ break;
+ case '\r':
+ putcharacter(sc,'r');
+ break;
+ case '\\':
+ putcharacter(sc,'\\');
+ break;
+ default: {
+ int d=*s/16;
+ putcharacter(sc,'x');
+ if(d<10) {
+ putcharacter(sc,d+'0');
+ } else {
+ putcharacter(sc,d-10+'A');
+ }
+ d=*s%16;
+ if(d<10) {
+ putcharacter(sc,d+'0');
+ } else {
+ putcharacter(sc,d-10+'A');
+ }
+ }
+ }
+ } else {
+ putcharacter(sc,*s);
+ }
+ s++;
+ }
+ putcharacter(sc,'"');
+}
+
+
+/* print atoms */
+static void printatom(scheme *sc, pointer l, int f) {
+ char *p;
+ int len;
+ atom2str(sc,l,f,&p,&len);
+ putchars(sc,p,len);
+}
+
+
+/* Uses internal buffer unless string pointer is already available */
+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
+ char *p;
+
+ if (l == sc->NIL) {
+ p = "()";
+ } else if (l == sc->T) {
+ p = "#t";
+ } else if (l == sc->F) {
+ p = "#f";
+ } else if (l == sc->EOF_OBJ) {
+ p = "#<EOF>";
+ } else if (is_port(l)) {
+ p = "#<PORT>";
+ } else if (is_number(l)) {
+ p = sc->strbuff;
+ if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
+ if(num_is_integer(l)) {
+ snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
+ } else {
+ snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
+ /* r5rs says there must be a '.' (unless 'e'?) */
+ f = strcspn(p, ".e");
+ if (p[f] == 0) {
+ p[f] = '.'; /* not found, so add '.0' at the end */
+ p[f+1] = '0';
+ p[f+2] = 0;
+ }
+ }
+ } else {
+ long v = ivalue(l);
+ if (f == 16) {
+ if (v >= 0)
+ snprintf(p, STRBUFFSIZE, "%lx", v);
+ else
+ snprintf(p, STRBUFFSIZE, "-%lx", -v);
+ } else if (f == 8) {
+ if (v >= 0)
+ snprintf(p, STRBUFFSIZE, "%lo", v);
+ else
+ snprintf(p, STRBUFFSIZE, "-%lo", -v);
+ } else if (f == 2) {
+ unsigned long b = (v < 0) ? -v : v;
+ p = &p[STRBUFFSIZE-1];
+ *p = 0;
+ do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
+ if (v < 0) *--p = '-';
+ }
+ }
+ } else if (is_string(l)) {
+ if (!f) {
+ *pp = strvalue(l);
+ *plen = strlength(l);
+ return;
+ } else { /* Hack, uses the fact that printing is needed */
+ *pp=sc->strbuff;
+ *plen=0;
+ printslashstring(sc, strvalue(l), strlength(l));
+ return;
+ }
+ } else if (is_character(l)) {
+ int c=charvalue(l);
+ p = sc->strbuff;
+ if (!f) {
+ p[0]=c;
+ p[1]=0;
+ } else {
+ switch(c) {
+ case ' ':
+ p = "#\\space";
+ break;
+ case '\n':
+ p = "#\\newline";
+ break;
+ case '\r':
+ p = "#\\return";
+ break;
+ case '\t':
+ p = "#\\tab";
+ break;
+ default:
+#if USE_ASCII_NAMES
+ if(c==127) {
+ p = "#\\del";
+ break;
+ } else if(c<32) {
+ snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
+ break;
+ }
+#else
+ if(c<32) {
+ snprintf(p,STRBUFFSIZE,"#\\x%x",c);
+ break;
+ }
+#endif
+ snprintf(p,STRBUFFSIZE,"#\\%c",c);
+ break;
+ }
+ }
+ } else if (is_symbol(l)) {
+ p = symname(l);
+ } else if (is_proc(l)) {
+ p = sc->strbuff;
+ snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
+ } else if (is_macro(l)) {
+ p = "#<MACRO>";
+ } else if (is_closure(l)) {
+ p = "#<CLOSURE>";
+ } else if (is_promise(l)) {
+ p = "#<PROMISE>";
+ } else if (is_foreign(l)) {
+ p = sc->strbuff;
+ snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
+ } else if (is_continuation(l)) {
+ p = "#<CONTINUATION>";
+ } else if (is_foreign_object(l)) {
+ p = sc->strbuff;
+ l->_object._foreign_object._vtable->to_string(sc, p, STRBUFFSIZE, l->_object._foreign_object._data);
+ } else {
+ p = "#<ERROR>";
+ }
+ *pp=p;
+ *plen=strlen(p);
+}
+/* ========== Routines for Evaluation Cycle ========== */
+
+/* make closure. c is code. e is environment */
+static pointer mk_closure(scheme *sc, pointer c, pointer e) {
+ pointer x = get_cell(sc, c, e);
+
+ typeflag(x) = T_CLOSURE;
+ car(x) = c;
+ cdr(x) = e;
+ return (x);
+}
+
+/* make continuation. */
+static pointer mk_continuation(scheme *sc, pointer d) {
+ pointer x = get_cell(sc, sc->NIL, d);
+
+ typeflag(x) = T_CONTINUATION;
+ cont_dump(x) = d;
+ return (x);
+}
+
+static pointer list_star(scheme *sc, pointer d) {
+ pointer p, q;
+ if(cdr(d)==sc->NIL) {
+ return car(d);
+ }
+ p=cons(sc,car(d),cdr(d));
+ q=p;
+ while(cdr(cdr(p))!=sc->NIL) {
+ d=cons(sc,car(p),cdr(p));
+ if(cdr(cdr(p))!=sc->NIL) {
+ p=cdr(d);
+ }
+ }
+ cdr(p)=car(cdr(p));
+ return q;
+}
+
+/* reverse list -- produce new list */
+static pointer reverse(scheme *sc, pointer term, pointer list) {
+/* a must be checked by gc */
+ pointer a = list, p = term;
+
+ for ( ; is_pair(a); a = cdr(a)) {
+ p = cons(sc, car(a), p);
+ }
+ return (p);
+}
+
+/* reverse list --- in-place */
+static pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
+ pointer p = list, result = term, q;
+
+ while (p != sc->NIL) {
+ q = cdr(p);
+ cdr(p) = result;
+ result = p;
+ p = q;
+ }
+ return (result);
+}
+
+/* append list -- produce new list (in reverse order) */
+static pointer revappend(scheme *sc, pointer a, pointer b) {
+ pointer result = a;
+ pointer p = b;
+
+ while (is_pair(p)) {
+ result = cons(sc, car(p), result);
+ p = cdr(p);
+ }
+
+ if (p == sc->NIL) {
+ return result;
+ }
+
+ return sc->F; /* signal an error */
+}
+
+/* equivalence of atoms */
+int eqv(pointer a, pointer b) {
+ if (is_string(a)) {
+ if (is_string(b))
+ return (strvalue(a) == strvalue(b));
+ else
+ return (0);
+ } else if (is_number(a)) {
+ if (is_number(b)) {
+ if (num_is_integer(a) == num_is_integer(b))
+ return num_eq(nvalue(a),nvalue(b));
+ }
+ return (0);
+ } else if (is_character(a)) {
+ if (is_character(b))
+ return charvalue(a)==charvalue(b);
+ else
+ return (0);
+ } else if (is_port(a)) {
+ if (is_port(b))
+ return a==b;
+ else
+ return (0);
+ } else if (is_proc(a)) {
+ if (is_proc(b))
+ return procnum(a)==procnum(b);
+ else
+ return (0);
+ } else {
+ return (a == b);
+ }
+}
+
+/* true or false value macro */
+/* () is #t in R5RS */
+#define is_true(p) ((p) != sc->F)
+#define is_false(p) ((p) == sc->F)
+
+
+/* ========== Environment implementation ========== */
+
+#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
+
+static int hash_fn(const char *key, int table_size)
+{
+ unsigned int hashed = 0;
+ const char *c;
+ int bits_per_int = sizeof(unsigned int)*8;
+
+ for (c = key; *c; c++) {
+ /* letters have about 5 bits in them */
+ hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
+ hashed ^= *c;
+ }
+ return hashed % table_size;
+}
+#endif
+
+/* Compares A and B. Returns an integer less than, equal to, or
+ * greater than zero if A is stored at a memory location that is
+ * numerical less than, equal to, or greater than that of B. */
+static int
+pointercmp(pointer a, pointer b)
+{
+ uintptr_t a_n = (uintptr_t) a;
+ uintptr_t b_n = (uintptr_t) b;
+
+ if (a_n < b_n)
+ return -1;
+ if (a_n > b_n)
+ return 1;
+ return 0;
+}
+
+#ifndef USE_ALIST_ENV
+
+/*
+ * In this implementation, each frame of the environment may be
+ * a hash table: a vector of alists hashed by variable name.
+ * In practice, we use a vector only for the initial frame;
+ * subsequent frames are too small and transient for the lookup
+ * speed to out-weigh the cost of making a new vector.
+ */
+
+static void new_frame_in_env(scheme *sc, pointer old_env)
+{
+ pointer new_frame;
+
+ /* The interaction-environment has about 480 variables in it. */
+ if (old_env == sc->NIL) {
+ new_frame = mk_vector(sc, 751);
+ } else {
+ new_frame = sc->NIL;
+ }
+
+ gc_disable(sc, 1);
+ sc->envir = immutable_cons(sc, new_frame, old_env);
+ gc_enable(sc);
+ setenvironment(sc->envir);
+}
+
+/* Find the slot in ENV under the key HDL. If ALL is given, look in
+ * all environments enclosing ENV. If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT. */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
+{
+ pointer x,y;
+ int location;
+ pointer *sl;
+ int d;
+ assert(is_symbol(hdl));
+
+ for (x = env; x != sc->NIL; x = cdr(x)) {
+ if (is_vector(car(x))) {
+ location = hash_fn(symname(hdl), vector_length(car(x)));
+ sl = vector_elem_slot(car(x), location);
+ } else {
+ sl = &car(x);
+ }
+ for (y = *sl ; y != sc->NIL; sl = &cdr(y), y = *sl) {
+ d = pointercmp(caar(y), hdl);
+ if (d == 0)
+ return car(y); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
+ }
+
+ if (x == env && sslot)
+ *sslot = sl; /* Insert here. */
+
+ if (!all)
+ return sc->NIL; /* Miss, and stop looking. */
+ }
+
+ return sc->NIL; /* Not found in any environment. */
+}
+
+#else /* USE_ALIST_ENV */
+
+static INLINE void new_frame_in_env(scheme *sc, pointer old_env)
+{
+ sc->envir = immutable_cons(sc, sc->NIL, old_env);
+ setenvironment(sc->envir);
+}
+
+/* Find the slot in ENV under the key HDL. If ALL is given, look in
+ * all environments enclosing ENV. If the lookup fails, and SSLOT is
+ * given, the position where the new slot has to be inserted is stored
+ * at SSLOT. */
+static pointer
+find_slot_spec_in_env(scheme *sc, pointer env, pointer hdl, int all, pointer **sslot)
+{
+ pointer x,y;
+ pointer *sl;
+ int d;
+ assert(is_symbol(hdl));
+
+ for (x = env; x != sc->NIL; x = cdr(x)) {
+ for (sl = &car(x), y = *sl; y != sc->NIL; sl = &cdr(y), y = *sl) {
+ d = pointercmp(caar(y), hdl);
+ if (d == 0)
+ return car(y); /* Hit. */
+ else if (d > 0)
+ break; /* Miss. */
+ }
+
+ if (x == env && sslot)
+ *sslot = sl; /* Insert here. */
+
+ if (!all)
+ return sc->NIL; /* Miss, and stop looking. */
+ }
+
+ return sc->NIL; /* Not found in any environment. */
+}
+
+#endif /* USE_ALIST_ENV else */
+
+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
+{
+ return find_slot_spec_in_env(sc, env, hdl, all, NULL);
+}
+
+/* Insert (VARIABLE, VALUE) at SSLOT. SSLOT must be obtained using
+ * find_slot_spec_in_env, and no insertion must be done between
+ * obtaining SSLOT and the call to this function. */
+static INLINE void new_slot_spec_in_env(scheme *sc,
+ pointer variable, pointer value,
+ pointer *sslot)
+{
+#define new_slot_spec_in_env_allocates 2
+ pointer slot;
+ gc_disable(sc, gc_reservations (new_slot_spec_in_env));
+ slot = immutable_cons(sc, variable, value);
+ *sslot = immutable_cons(sc, slot, *sslot);
+ gc_enable(sc);
+}
+
+static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
+{
+#define new_slot_in_env_allocates new_slot_spec_in_env_allocates
+ pointer slot;
+ pointer *sslot;
+ assert(is_symbol(variable));
+ slot = find_slot_spec_in_env(sc, sc->envir, variable, 0, &sslot);
+ assert(slot == sc->NIL);
+ new_slot_spec_in_env(sc, variable, value, sslot);
+}
+
+static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
+{
+ (void)sc;
+ cdr(slot) = value;
+}
+
+static INLINE pointer slot_value_in_env(pointer slot)
+{
+ return cdr(slot);
+}
+
+
+/* ========== Evaluation Cycle ========== */
+
+
+static enum scheme_opcodes
+_Error_1(scheme *sc, const char *s, pointer a) {
+ const char *str = s;
+ pointer history;
+#if USE_ERROR_HOOK
+ pointer x;
+ pointer hdl=sc->ERROR_HOOK;
+#endif
+
+#if SHOW_ERROR_LINE
+ char sbuf[STRBUFFSIZE];
+#endif
+
+ history = history_flatten(sc);
+
+#if SHOW_ERROR_LINE
+ /* make sure error is not in REPL */
+ if (((sc->load_stack[sc->file_i].kind & port_file) == 0
+ || sc->load_stack[sc->file_i].rep.stdio.file != stdin)) {
+ pointer tag;
+ const char *fname;
+ int ln;
+
+ if (history != sc->NIL && has_tag(car(history))
+ && (tag = get_tag(sc, car(history)))
+ && is_string(car(tag)) && is_integer(cdr(tag))) {
+ fname = string_value(car(tag));
+ ln = ivalue_unchecked(cdr(tag));
+ } else {
+ fname = string_value(sc->load_stack[sc->file_i].filename);
+ ln = ivalue_unchecked(sc->load_stack[sc->file_i].curr_line);
+ }
+
+ /* should never happen */
+ if(!fname) fname = "<unknown>";
+
+ /* we started from 0 */
+ ln++;
+ snprintf(sbuf, STRBUFFSIZE, "%s:%i: %s", fname, ln, s);
+
+ str = (const char*)sbuf;
+ }
+#endif
+
+#if USE_ERROR_HOOK
+ x=find_slot_in_env(sc,sc->envir,hdl,1);
+ if (x != sc->NIL) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE,
+ cons(sc, history, sc->NIL)),
+ sc->NIL);
+ if(a!=0) {
+ sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc, a, sc->NIL)),
+ sc->code);
+ } else {
+ sc->code = cons(sc, sc->F, sc->code);
+ }
+ sc->code = cons(sc, mk_string(sc, str), sc->code);
+ setimmutable(car(sc->code));
+ sc->code = cons(sc, slot_value_in_env(x), sc->code);
+ return OP_EVAL;
+ }
+#endif
+
+ if(a!=0) {
+ sc->args = cons(sc, (a), sc->NIL);
+ } else {
+ sc->args = sc->NIL;
+ }
+ sc->args = cons(sc, mk_string(sc, str), sc->args);
+ setimmutable(car(sc->args));
+ return OP_ERR0;
+}
+#define Error_1(sc,s, a) { op = _Error_1(sc,s,a); goto dispatch; }
+#define Error_0(sc,s) { op = _Error_1(sc,s,0); goto dispatch; }
+
+/* Too small to turn into function */
+# define BEGIN do {
+# define END } while (0)
+
+
+
+/* Flags. The interpreter has a flags field. When the interpreter
+ * pushes a frame to the dump stack, it is encoded with the opcode.
+ * Therefore, we do not use the least significant byte. */
+
+/* Masks used to encode and decode opcode and flags. */
+#define S_OP_MASK 0x000000ff
+#define S_FLAG_MASK 0xffffff00
+
+/* Set if the interpreter evaluates an expression in a tail context
+ * (see R5RS, section 3.5). If a function, procedure, or continuation
+ * is invoked while this flag is set, the call is recorded as tail
+ * call in the history buffer. */
+#define S_FLAG_TAIL_CONTEXT 0x00000100
+
+/* Set flag F. */
+#define s_set_flag(sc, f) \
+ BEGIN \
+ (sc)->flags |= S_FLAG_ ## f; \
+ END
+
+/* Clear flag F. */
+#define s_clear_flag(sc, f) \
+ BEGIN \
+ (sc)->flags &= ~ S_FLAG_ ## f; \
+ END
+
+/* Check if flag F is set. */
+#define s_get_flag(sc, f) \
+ !!((sc)->flags & S_FLAG_ ## f)
+
+
+
+/* Bounce back to Eval_Cycle and execute A. */
+#define s_goto(sc, a) { op = (a); goto dispatch; }
+
+#if USE_THREADED_CODE
+
+/* Do not bounce back to Eval_Cycle but execute A by jumping directly
+ * to it. */
+#define s_thread_to(sc, a) \
+ BEGIN \
+ op = (a); \
+ goto a; \
+ END
+
+/* Define a label OP and emit a case statement for OP. For use in the
+ * dispatch function. The slightly peculiar goto that is never
+ * executed avoids warnings about unused labels. */
+#define CASE(OP) case OP: if (0) goto OP; OP
+
+#else /* USE_THREADED_CODE */
+#define s_thread_to(sc, a) s_goto(sc, a)
+#define CASE(OP) case OP
+#endif /* USE_THREADED_CODE */
+
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A. */
+#define s_return(sc, a) s_goto(sc, _s_return(sc, a, 0))
+
+/* Return to the previous frame on the dump stack, setting the current
+ * value to A, and re-enable the garbage collector. */
+#define s_return_enable_gc(sc, a) s_goto(sc, _s_return(sc, a, 1))
+
+static INLINE void dump_stack_reset(scheme *sc)
+{
+ sc->dump = sc->NIL;
+}
+
+static INLINE void dump_stack_initialize(scheme *sc)
+{
+ dump_stack_reset(sc);
+ sc->frame_freelist = sc->NIL;
+}
+
+static void dump_stack_free(scheme *sc)
+{
+ dump_stack_initialize(sc);
+}
+
+const int frame_length = 4;
+
+static pointer
+dump_stack_make_frame(scheme *sc)
+{
+ pointer frame;
+
+ frame = mk_vector(sc, frame_length);
+ if (! sc->no_memory)
+ setframe(frame);
+
+ return frame;
+}
+
+static INLINE pointer *
+frame_slots(pointer frame)
+{
+ return &frame->_object._vector._elements[0];
+}
+
+#define frame_payload vector_length
+
+static pointer
+dump_stack_allocate_frame(scheme *sc)
+{
+ pointer frame = sc->frame_freelist;
+ if (frame == sc->NIL) {
+ if (gc_enabled(sc))
+ frame = dump_stack_make_frame(sc);
+ else
+ gc_reservation_failure(sc);
+ } else
+ sc->frame_freelist = *frame_slots(frame);
+ return frame;
+}
+
+static void
+dump_stack_deallocate_frame(scheme *sc, pointer frame)
+{
+ pointer *p = frame_slots(frame);
+ *p++ = sc->frame_freelist;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ *p++ = sc->NIL;
+ sc->frame_freelist = frame;
+}
+
+static void
+dump_stack_preallocate_frame(scheme *sc)
+{
+ pointer frame = dump_stack_make_frame(sc);
+ if (! sc->no_memory)
+ dump_stack_deallocate_frame(sc, frame);
+}
+
+static enum scheme_opcodes
+_s_return(scheme *sc, pointer a, int enable_gc) {
+ pointer dump = sc->dump;
+ pointer *p;
+ unsigned long v;
+ enum scheme_opcodes next_op;
+ sc->value = (a);
+ if (enable_gc)
+ gc_enable(sc);
+ if (dump == sc->NIL)
+ return OP_QUIT;
+ v = frame_payload(dump);
+ next_op = (int) (v & S_OP_MASK);
+ sc->flags = v & S_FLAG_MASK;
+ p = frame_slots(dump);
+ sc->args = *p++;
+ sc->envir = *p++;
+ sc->code = *p++;
+ sc->dump = *p++;
+ dump_stack_deallocate_frame(sc, dump);
+ return next_op;
+}
+
+static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
+#define s_save_allocates 0
+ pointer dump;
+ pointer *p;
+ gc_disable(sc, gc_reservations (s_save));
+ dump = dump_stack_allocate_frame(sc);
+ frame_payload(dump) = (size_t) (sc->flags | (unsigned long) op);
+ p = frame_slots(dump);
+ *p++ = args;
+ *p++ = sc->envir;
+ *p++ = code;
+ *p++ = sc->dump;
+ sc->dump = dump;
+ gc_enable(sc);
+}
+
+static INLINE void dump_stack_mark(scheme *sc)
+{
+ mark(sc->dump);
+ mark(sc->frame_freelist);
+}
+
+
+
+#if USE_HISTORY
+
+static void
+history_free(scheme *sc)
+{
+ sc->free(sc->history.m);
+ sc->history.tailstacks = sc->NIL;
+ sc->history.callstack = sc->NIL;
+}
+
+static pointer
+history_init(scheme *sc, size_t N, size_t M)
+{
+ size_t i;
+ struct history *h = &sc->history;
+
+ h->N = N;
+ h->mask_N = N - 1;
+ h->n = N - 1;
+ assert ((N & h->mask_N) == 0);
+
+ h->M = M;
+ h->mask_M = M - 1;
+ assert ((M & h->mask_M) == 0);
+
+ h->callstack = mk_vector(sc, N);
+ if (h->callstack == sc->sink)
+ goto fail;
+
+ h->tailstacks = mk_vector(sc, N);
+ for (i = 0; i < N; i++) {
+ pointer tailstack = mk_vector(sc, M);
+ if (tailstack == sc->sink)
+ goto fail;
+ set_vector_elem(h->tailstacks, i, tailstack);
+ }
+
+ h->m = sc->malloc(N * sizeof *h->m);
+ if (h->m == NULL)
+ goto fail;
+
+ for (i = 0; i < N; i++)
+ h->m[i] = 0;
+
+ return sc->T;
+
+fail:
+ history_free(sc);
+ return sc->F;
+}
+
+static void
+history_mark(scheme *sc)
+{
+ struct history *h = &sc->history;
+ mark(h->callstack);
+ mark(h->tailstacks);
+}
+
+#define add_mod(a, b, mask) (((a) + (b)) & (mask))
+#define sub_mod(a, b, mask) add_mod(a, (mask) + 1 - (b), mask)
+
+static INLINE void
+tailstack_clear(scheme *sc, pointer v)
+{
+ assert(is_vector(v));
+ /* XXX optimize */
+ fill_vector(v, sc->NIL);
+}
+
+static pointer
+callstack_pop(scheme *sc)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ pointer item;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ item = vector_elem(h->callstack, n);
+ /* Clear our frame so that it can be gc'ed and we don't run into it
+ * when walking the history. */
+ set_vector_elem(h->callstack, n, sc->NIL);
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+
+ /* Exit from the frame. */
+ h->n = sub_mod(h->n, 1, h->mask_N);
+
+ return item;
+}
+
+static void
+callstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new frame. */
+ n = h->n = add_mod(n, 1, h->mask_N);
+
+ /* Initialize tail stack. */
+ tailstack_clear(sc, vector_elem(h->tailstacks, n));
+ h->m[n] = h->mask_M;
+
+ set_vector_elem(h->callstack, n, item);
+}
+
+static void
+tailstack_push(scheme *sc, pointer item)
+{
+ struct history *h = &sc->history;
+ size_t n = h->n;
+ size_t m = h->m[n];
+
+ if (h->callstack == sc->NIL)
+ return;
+
+ /* Enter a new tail frame. */
+ m = h->m[n] = add_mod(m, 1, h->mask_M);
+ set_vector_elem(vector_elem(h->tailstacks, n), m, item);
+}
+
+static pointer
+tailstack_flatten(scheme *sc, pointer tailstack, size_t i, size_t n,
+ pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->M);
+ assert(n < h->M);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(tailstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* Add us. */
+ acc = cons(sc, frame, acc);
+
+ return tailstack_flatten(sc, tailstack, i - 1, sub_mod(n, 1, h->mask_M),
+ acc);
+}
+
+static pointer
+callstack_flatten(scheme *sc, size_t i, size_t n, pointer acc)
+{
+ struct history *h = &sc->history;
+ pointer frame;
+
+ assert(i <= h->N);
+ assert(n < h->N);
+
+ if (acc == sc->sink)
+ return sc->sink;
+
+ if (i == 0) {
+ /* We reached the end, but we did not see a unused frame. Signal
+ this using '... . */
+ return cons(sc, mk_symbol(sc, "..."), acc);
+ }
+
+ frame = vector_elem(h->callstack, n);
+ if (frame == sc->NIL) {
+ /* A unused frame. We reached the end of the history. */
+ return acc;
+ }
+
+ /* First, emit the tail calls. */
+ acc = tailstack_flatten(sc, vector_elem(h->tailstacks, n), h->M, h->m[n],
+ acc);
+
+ /* Then us. */
+ acc = cons(sc, frame, acc);
+
+ return callstack_flatten(sc, i - 1, sub_mod(n, 1, h->mask_N), acc);
+}
+
+static pointer
+history_flatten(scheme *sc)
+{
+ struct history *h = &sc->history;
+ pointer history;
+
+ if (h->callstack == sc->NIL)
+ return sc->NIL;
+
+ history = callstack_flatten(sc, h->N, h->n, sc->NIL);
+ if (history == sc->sink)
+ return sc->sink;
+
+ return reverse_in_place(sc, sc->NIL, history);
+}
+
+#undef add_mod
+#undef sub_mod
+
+#else /* USE_HISTORY */
+
+#define history_init(SC, A, B) (void) 0
+#define history_free(SC) (void) 0
+#define callstack_pop(SC) (void) 0
+#define callstack_push(SC, X) (void) 0
+#define tailstack_push(SC, X) (void) 0
+
+#endif /* USE_HISTORY */
+
+
+
+#if USE_PLIST
+static pointer
+get_property(scheme *sc, pointer obj, pointer key)
+{
+ pointer x;
+
+ assert (is_symbol(obj));
+ assert (is_symbol(key));
+
+ for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == key)
+ break;
+ }
+
+ if (x != sc->NIL)
+ return cdar(x);
+
+ return sc->NIL;
+}
+
+static pointer
+set_property(scheme *sc, pointer obj, pointer key, pointer value)
+{
+#define set_property_allocates 2
+ pointer x;
+
+ assert (is_symbol(obj));
+ assert (is_symbol(key));
+
+ for (x = symprop(obj); x != sc->NIL; x = cdr(x)) {
+ if (caar(x) == key)
+ break;
+ }
+
+ if (x != sc->NIL)
+ cdar(x) = value;
+ else {
+ gc_disable(sc, gc_reservations(set_property));
+ symprop(obj) = cons(sc, cons(sc, key, value), symprop(obj));
+ gc_enable(sc);
+ }
+
+ return sc->T;
+}
+#endif
+
+
+
+static int is_list(scheme *sc, pointer a)
+{ return list_length(sc,a) >= 0; }
+
+/* Result is:
+ proper list: length
+ circular list: -1
+ not even a pair: -2
+ dotted list: -2 minus length before dot
+*/
+int list_length(scheme *sc, pointer a) {
+ int i=0;
+ pointer slow, fast;
+
+ slow = fast = a;
+ while (1)
+ {
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ fast = cdr(fast);
+ ++i;
+ if (fast == sc->NIL)
+ return i;
+ if (!is_pair(fast))
+ return -2 - i;
+ ++i;
+ fast = cdr(fast);
+
+ /* Safe because we would have already returned if `fast'
+ encountered a non-pair. */
+ slow = cdr(slow);
+ if (fast == slow)
+ {
+ /* the fast pointer has looped back around and caught up
+ with the slow pointer, hence the structure is circular,
+ not of finite length, and therefore not a list */
+ return -1;
+ }
+ }
+}
+
+
+
+#if GPGRT_GCC_VERSION >= 80000
+# pragma GCC diagnostic push
+# pragma GCC diagnostic ignored "-Wimplicit-fallthrough"
+#endif
+
+#define s_retbool(tf) s_return(sc,(tf) ? sc->T : sc->F)
+
+/* kernel of this interpreter */
+static void
+Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
+ for (;;) {
+ pointer x, y;
+ pointer callsite;
+ num v;
+#if USE_MATH
+ double dd;
+#endif
+ int (*comp_func)(num, num) = NULL;
+ const struct op_code_info *pcd;
+
+ dispatch:
+ pcd = &dispatch_table[op];
+ if (pcd->name[0] != 0) { /* if built-in function, check arguments */
+ char msg[STRBUFFSIZE];
+ if (! check_arguments (sc, pcd, msg, sizeof msg)) {
+ s_goto(sc, _Error_1(sc, msg, 0));
+ }
+ }
+
+ if(sc->no_memory) {
+ fprintf(stderr,"No memory!\n");
+ exit(1);
+ }
+ ok_to_freely_gc(sc);
+
+ switch (op) {
+ CASE(OP_LOAD): /* load */
+ if(file_interactive(sc)) {
+ fprintf(sc->outport->_object._port->rep.stdio.file,
+ "Loading %s\n", strvalue(car(sc->args)));
+ }
+ if (!file_push(sc, car(sc->args))) {
+ Error_1(sc,"unable to open", car(sc->args));
+ }
+ else
+ {
+ sc->args = mk_integer(sc,sc->file_i);
+ s_thread_to(sc,OP_T0LVL);
+ }
+
+ CASE(OP_T0LVL): /* top level */
+ /* If we reached the end of file, this loop is done. */
+ if(sc->loadport->_object._port->kind & port_saw_EOF)
+ {
+ if(sc->file_i == 0)
+ {
+ sc->args=sc->NIL;
+ sc->nesting = sc->nesting_stack[0];
+ s_thread_to(sc,OP_QUIT);
+ }
+ else
+ {
+ file_pop(sc);
+ s_return(sc,sc->value);
+ }
+ /* NOTREACHED */
+ }
+
+ /* If interactive, be nice to user. */
+ if(file_interactive(sc))
+ {
+ sc->envir = sc->global_env;
+ dump_stack_reset(sc);
+ putstr(sc,"\n");
+ putstr(sc,prompt);
+ }
+
+ /* Set up another iteration of REPL */
+ sc->nesting=0;
+ sc->save_inport=sc->inport;
+ sc->inport = sc->loadport;
+ s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
+ s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
+ s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
+ s_thread_to(sc,OP_READ_INTERNAL);
+
+ CASE(OP_T1LVL): /* top level */
+ sc->code = sc->value;
+ sc->inport=sc->save_inport;
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_READ_INTERNAL): /* internal read */
+ sc->tok = token(sc);
+ if(sc->tok==TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
+ s_thread_to(sc,OP_RDSEXPR);
+
+ CASE(OP_GENSYM):
+ s_return(sc, gensym(sc));
+
+ CASE(OP_VALUEPRINT): /* print evaluation result */
+ /* OP_VALUEPRINT is always pushed, because when changing from
+ non-interactive to interactive mode, it needs to be
+ already on the stack */
+ if(sc->tracing) {
+ putstr(sc,"\nGives: ");
+ }
+ if(file_interactive(sc)) {
+ sc->print_flag = 1;
+ sc->args = sc->value;
+ s_thread_to(sc,OP_P0LIST);
+ } else {
+ s_return(sc,sc->value);
+ }
+
+ CASE(OP_EVAL): /* main part of evaluation */
+#if USE_TRACING
+ if(sc->tracing) {
+ /*s_save(sc,OP_VALUEPRINT,sc->NIL,sc->NIL);*/
+ s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
+ sc->args=sc->code;
+ putstr(sc,"\nEval: ");
+ s_thread_to(sc,OP_P0LIST);
+ }
+ /* fall through */
+ CASE(OP_REAL_EVAL):
+#endif
+ if (is_symbol(sc->code)) { /* symbol */
+ x=find_slot_in_env(sc,sc->envir,sc->code,1);
+ if (x != sc->NIL) {
+ s_return(sc,slot_value_in_env(x));
+ } else {
+ Error_1(sc, "eval: unbound variable", sc->code);
+ }
+ } else if (is_pair(sc->code)) {
+ if (is_syntax(x = car(sc->code))) { /* SYNTAX */
+ sc->code = cdr(sc->code);
+ s_goto(sc, syntaxnum(sc, x));
+ } else {/* first, eval top element and eval arguments */
+ s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
+ /* If no macros => s_save(sc,OP_E1ARGS, sc->NIL, cdr(sc->code));*/
+ sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ }
+ } else {
+ s_return(sc,sc->code);
+ }
+
+ CASE(OP_E0ARGS): /* eval arguments */
+ if (is_macro(sc->value)) { /* macro expansion */
+ gc_disable(sc, 1 + gc_reservations (s_save));
+ s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
+ sc->args = cons(sc,sc->code, sc->NIL);
+ gc_enable(sc);
+ sc->code = sc->value;
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_APPLY);
+ } else {
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->code, sc->NIL);
+ gc_enable(sc);
+ sc->code = cdr(sc->code);
+ s_thread_to(sc,OP_E1ARGS);
+ }
+
+ CASE(OP_E1ARGS): /* eval arguments */
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->value, sc->args);
+ gc_enable(sc);
+ if (is_pair(sc->code)) { /* continue */
+ s_save(sc,OP_E1ARGS, sc->args, cdr(sc->code));
+ sc->code = car(sc->code);
+ sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ } else { /* end */
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ s_thread_to(sc,OP_APPLY_CODE);
+ }
+
+#if USE_TRACING
+ CASE(OP_TRACING): {
+ int tr=sc->tracing;
+ sc->tracing=ivalue(car(sc->args));
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_integer(sc, tr));
+ }
+#endif
+
+#if USE_HISTORY
+ CASE(OP_CALLSTACK_POP): /* pop the call stack */
+ callstack_pop(sc);
+ s_return(sc, sc->value);
+#endif
+
+ CASE(OP_APPLY_CODE): /* apply 'cadr(args)' to 'cddr(args)',
+ * record in the history as invoked from
+ * 'car(args)' */
+ free_cons(sc, sc->args, &callsite, &sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ /* Fallthrough. */
+
+ CASE(OP_APPLY): /* apply 'code' to 'args' */
+#if USE_TRACING
+ if(sc->tracing) {
+ s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
+ sc->print_flag = 1;
+ /* sc->args=cons(sc,sc->code,sc->args);*/
+ putstr(sc,"\nApply to: ");
+ s_thread_to(sc,OP_P0LIST);
+ }
+ /* fall through */
+ CASE(OP_REAL_APPLY):
+#endif
+#if USE_HISTORY
+ if (op != OP_APPLY_CODE)
+ callsite = sc->code;
+ if (s_get_flag(sc, TAIL_CONTEXT)) {
+ /* We are evaluating a tail call. */
+ tailstack_push(sc, callsite);
+ } else {
+ callstack_push(sc, callsite);
+ s_save(sc, OP_CALLSTACK_POP, sc->NIL, sc->NIL);
+ }
+#endif
+
+ if (is_proc(sc->code)) {
+ s_goto(sc,procnum(sc->code)); /* PROCEDURE */
+ } else if (is_foreign(sc->code))
+ {
+ /* Keep nested calls from GC'ing the arglist */
+ push_recent_alloc(sc,sc->args,sc->NIL);
+ x=sc->code->_object._ff(sc,sc->args);
+ s_return(sc,x);
+ } else if (is_closure(sc->code) || is_macro(sc->code)
+ || is_promise(sc->code)) { /* CLOSURE */
+ /* Should not accept promise */
+ /* make environment */
+ new_frame_in_env(sc, closure_env(sc->code));
+ for (x = car(closure_code(sc->code)), y = sc->args;
+ is_pair(x); x = cdr(x), y = cdr(y)) {
+ if (y == sc->NIL) {
+ Error_1(sc, "not enough arguments, missing", x);
+ } else if (is_symbol(car(x))) {
+ new_slot_in_env(sc, car(x), car(y));
+ } else {
+ Error_1(sc, "syntax error in closure: not a symbol", car(x));
+ }
+ }
+
+ if (x == sc->NIL) {
+ if (y != sc->NIL) {
+ Error_0(sc, "too many arguments");
+ }
+ } else if (is_symbol(x))
+ new_slot_in_env(sc, x, y);
+ else {
+ Error_1(sc, "syntax error in closure: not a symbol", x);
+ }
+ sc->code = cdr(closure_code(sc->code));
+ sc->args = sc->NIL;
+ s_set_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_BEGIN);
+ } else if (is_continuation(sc->code)) { /* CONTINUATION */
+ sc->dump = cont_dump(sc->code);
+ s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
+ } else {
+ Error_1(sc,"illegal function",sc->code);
+ }
+
+ CASE(OP_DOMACRO): /* do macro */
+ sc->code = sc->value;
+ s_thread_to(sc,OP_EVAL);
+
+#if USE_COMPILE_HOOK
+ CASE(OP_LAMBDA): /* lambda */
+ /* If the hook is defined, apply it to sc->code, otherwise
+ set sc->value fall through */
+ {
+ pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
+ if(f==sc->NIL) {
+ sc->value = sc->code;
+ /* Fallthru */
+ } else {
+ gc_disable(sc, 1 + gc_reservations (s_save));
+ s_save(sc,OP_LAMBDA1,sc->args,sc->code);
+ sc->args=cons(sc,sc->code,sc->NIL);
+ gc_enable(sc);
+ sc->code=slot_value_in_env(f);
+ s_thread_to(sc,OP_APPLY);
+ }
+ }
+ /* Fallthrough. */
+#else
+ CASE(OP_LAMBDA): /* lambda */
+ sc->value = sc->code;
+ /* Fallthrough. */
+#endif
+
+ CASE(OP_LAMBDA1):
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_closure(sc, sc->value, sc->envir));
+
+
+ CASE(OP_MKCLOSURE): /* make-closure */
+ x=car(sc->args);
+ if(car(x)==sc->LAMBDA) {
+ x=cdr(x);
+ }
+ if(cdr(sc->args)==sc->NIL) {
+ y=sc->envir;
+ } else {
+ y=cadr(sc->args);
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_closure(sc, x, y));
+
+ CASE(OP_QUOTE): /* quote */
+ s_return(sc,car(sc->code));
+
+ CASE(OP_DEF0): /* define */
+ if(is_immutable(car(sc->code)))
+ Error_1(sc,"define: unable to alter immutable", car(sc->code));
+
+ if (is_pair(car(sc->code))) {
+ x = caar(sc->code);
+ gc_disable(sc, 2);
+ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+ gc_enable(sc);
+ } else {
+ x = car(sc->code);
+ sc->code = cadr(sc->code);
+ }
+ if (!is_symbol(x)) {
+ Error_0(sc,"variable is not a symbol");
+ }
+ s_save(sc,OP_DEF1, sc->NIL, x);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_DEF1): { /* define */
+ pointer *sslot;
+ x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, sc->value);
+ } else {
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
+ }
+ s_return(sc,sc->code);
+ }
+
+ CASE(OP_DEFP): /* defined? */
+ x=sc->envir;
+ if(cdr(sc->args)!=sc->NIL) {
+ x=cadr(sc->args);
+ }
+ s_retbool(find_slot_in_env(sc,x,car(sc->args),1)!=sc->NIL);
+
+ CASE(OP_SET0): /* set! */
+ if(is_immutable(car(sc->code)))
+ Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
+ s_save(sc,OP_SET1, sc->NIL, car(sc->code));
+ sc->code = cadr(sc->code);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_SET1): /* set! */
+ y=find_slot_in_env(sc,sc->envir,sc->code,1);
+ if (y != sc->NIL) {
+ set_slot_in_env(sc, y, sc->value);
+ s_return(sc,sc->value);
+ } else {
+ Error_1(sc, "set!: unbound variable", sc->code);
+ }
+
+
+ CASE(OP_BEGIN): /* begin */
+ {
+ int last;
+
+ if (!is_pair(sc->code)) {
+ s_return(sc,sc->code);
+ }
+
+ last = cdr(sc->code) == sc->NIL;
+ if (!last) {
+ s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
+ }
+ sc->code = car(sc->code);
+ if (! last)
+ /* This is not the end of the list. This is not a tail
+ * position. */
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ }
+
+ CASE(OP_IF0): /* if */
+ s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_IF1): /* if */
+ if (is_true(sc->value))
+ sc->code = car(sc->code);
+ else
+ sc->code = cadr(sc->code); /* (if #f 1) ==> () because
+ * car(sc->NIL) = sc->NIL */
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_LET0): /* let */
+ sc->args = sc->NIL;
+ sc->value = sc->code;
+ sc->code = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code);
+ s_thread_to(sc,OP_LET1);
+
+ CASE(OP_LET1): /* let (calculate parameters) */
+ gc_disable(sc, 1 + (is_pair(sc->code) ? gc_reservations (s_save) : 0));
+ sc->args = cons(sc, sc->value, sc->args);
+ if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ gc_enable(sc);
+ Error_1(sc, "Bad syntax of binding spec in let",
+ car(sc->code));
+ }
+ s_save(sc,OP_LET1, sc->args, cdr(sc->code));
+ gc_enable(sc);
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ } else { /* end */
+ gc_enable(sc);
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ s_thread_to(sc,OP_LET2);
+ }
+
+ CASE(OP_LET2): /* let */
+ new_frame_in_env(sc, sc->envir);
+ for (x = is_symbol(car(sc->code)) ? cadr(sc->code) : car(sc->code), y = sc->args;
+ y != sc->NIL; x = cdr(x), y = cdr(y)) {
+ new_slot_in_env(sc, caar(x), car(y));
+ }
+ if (is_symbol(car(sc->code))) { /* named let */
+ for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
+ if (!is_pair(x))
+ Error_1(sc, "Bad syntax of binding in let", x);
+ if (!is_list(sc, car(x)))
+ Error_1(sc, "Bad syntax of binding in let", car(x));
+ gc_disable(sc, 1);
+ sc->args = cons(sc, caar(x), sc->args);
+ gc_enable(sc);
+ }
+ gc_disable(sc, 2 + gc_reservations (new_slot_in_env));
+ x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
+ new_slot_in_env(sc, car(sc->code), x);
+ gc_enable(sc);
+ sc->code = cddr(sc->code);
+ sc->args = sc->NIL;
+ } else {
+ sc->code = cdr(sc->code);
+ sc->args = sc->NIL;
+ }
+ s_thread_to(sc,OP_BEGIN);
+
+ CASE(OP_LET0AST): /* let* */
+ if (car(sc->code) == sc->NIL) {
+ new_frame_in_env(sc, sc->envir);
+ sc->code = cdr(sc->code);
+ s_thread_to(sc,OP_BEGIN);
+ }
+ if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
+ Error_1(sc, "Bad syntax of binding spec in let*", car(sc->code));
+ }
+ s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
+ sc->code = cadaar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_LET1AST): /* let* (make new frame) */
+ new_frame_in_env(sc, sc->envir);
+ s_thread_to(sc,OP_LET2AST);
+
+ CASE(OP_LET2AST): /* let* (calculate parameters) */
+ new_slot_in_env(sc, caar(sc->code), sc->value);
+ sc->code = cdr(sc->code);
+ if (is_pair(sc->code)) { /* continue */
+ s_save(sc,OP_LET2AST, sc->args, sc->code);
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ } else { /* end */
+ sc->code = sc->args;
+ sc->args = sc->NIL;
+ s_thread_to(sc,OP_BEGIN);
+ }
+
+ CASE(OP_LET0REC): /* letrec */
+ new_frame_in_env(sc, sc->envir);
+ sc->args = sc->NIL;
+ sc->value = sc->code;
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_LET1REC);
+
+ CASE(OP_LET1REC): /* letrec (calculate parameters) */
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->value, sc->args);
+ gc_enable(sc);
+ if (is_pair(sc->code)) { /* continue */
+ if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
+ Error_1(sc, "Bad syntax of binding spec in letrec",
+ car(sc->code));
+ }
+ s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
+ sc->code = cadar(sc->code);
+ sc->args = sc->NIL;
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ } else { /* end */
+ sc->args = reverse_in_place(sc, sc->NIL, sc->args);
+ sc->code = car(sc->args);
+ sc->args = cdr(sc->args);
+ s_thread_to(sc,OP_LET2REC);
+ }
+
+ CASE(OP_LET2REC): /* letrec */
+ for (x = car(sc->code), y = sc->args; y != sc->NIL; x = cdr(x), y = cdr(y)) {
+ new_slot_in_env(sc, caar(x), car(y));
+ }
+ sc->code = cdr(sc->code);
+ sc->args = sc->NIL;
+ s_thread_to(sc,OP_BEGIN);
+
+ CASE(OP_COND0): /* cond */
+ if (!is_pair(sc->code)) {
+ Error_0(sc,"syntax error in cond");
+ }
+ s_save(sc,OP_COND1, sc->NIL, sc->code);
+ sc->code = caar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_COND1): /* cond */
+ if (is_true(sc->value)) {
+ if ((sc->code = cdar(sc->code)) == sc->NIL) {
+ s_return(sc,sc->value);
+ }
+ if(!sc->code || car(sc->code)==sc->FEED_TO) {
+ if(!is_pair(cdr(sc->code))) {
+ Error_0(sc,"syntax error in cond");
+ }
+ gc_disable(sc, 4);
+ x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
+ sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
+ gc_enable(sc);
+ s_thread_to(sc,OP_EVAL);
+ }
+ s_thread_to(sc,OP_BEGIN);
+ } else {
+ if ((sc->code = cdr(sc->code)) == sc->NIL) {
+ s_return(sc,sc->NIL);
+ } else {
+ s_save(sc,OP_COND1, sc->NIL, sc->code);
+ sc->code = caar(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+ }
+ }
+
+ CASE(OP_DELAY): /* delay */
+ gc_disable(sc, 2);
+ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
+ typeflag(x)=T_PROMISE;
+ s_return_enable_gc(sc,x);
+
+ CASE(OP_AND0): /* and */
+ if (sc->code == sc->NIL) {
+ s_return(sc,sc->T);
+ }
+ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_AND1): /* and */
+ if (is_false(sc->value)) {
+ s_return(sc,sc->value);
+ } else if (sc->code == sc->NIL) {
+ s_return(sc,sc->value);
+ } else {
+ s_save(sc,OP_AND1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_EVAL);
+ }
+
+ CASE(OP_OR0): /* or */
+ if (sc->code == sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_OR1): /* or */
+ if (is_true(sc->value)) {
+ s_return(sc,sc->value);
+ } else if (sc->code == sc->NIL) {
+ s_return(sc,sc->value);
+ } else {
+ s_save(sc,OP_OR1, sc->NIL, cdr(sc->code));
+ if (cdr(sc->code) != sc->NIL)
+ s_clear_flag(sc, TAIL_CONTEXT);
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_EVAL);
+ }
+
+ CASE(OP_C0STREAM): /* cons-stream */
+ s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_C1STREAM): /* cons-stream */
+ sc->args = sc->value; /* save sc->value to register sc->args for gc */
+ gc_disable(sc, 3);
+ x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
+ typeflag(x)=T_PROMISE;
+ s_return_enable_gc(sc, cons(sc, sc->args, x));
+
+ CASE(OP_MACRO0): /* macro */
+ if (is_pair(car(sc->code))) {
+ x = caar(sc->code);
+ gc_disable(sc, 2);
+ sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
+ gc_enable(sc);
+ } else {
+ x = car(sc->code);
+ sc->code = cadr(sc->code);
+ }
+ if (!is_symbol(x)) {
+ Error_0(sc,"variable is not a symbol");
+ }
+ s_save(sc,OP_MACRO1, sc->NIL, x);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_MACRO1): { /* macro */
+ pointer *sslot;
+ typeflag(sc->value) = T_MACRO;
+ x = find_slot_spec_in_env(sc, sc->envir, sc->code, 0, &sslot);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, sc->value);
+ } else {
+ new_slot_spec_in_env(sc, sc->code, sc->value, sslot);
+ }
+ s_return(sc,sc->code);
+ }
+
+ CASE(OP_CASE0): /* case */
+ s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
+ sc->code = car(sc->code);
+ s_clear_flag(sc, TAIL_CONTEXT);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_CASE1): /* case */
+ for (x = sc->code; x != sc->NIL; x = cdr(x)) {
+ if (!is_pair(y = caar(x))) {
+ break;
+ }
+ for ( ; y != sc->NIL; y = cdr(y)) {
+ if (eqv(car(y), sc->value)) {
+ break;
+ }
+ }
+ if (y != sc->NIL) {
+ break;
+ }
+ }
+ if (x != sc->NIL) {
+ if (is_pair(caar(x))) {
+ sc->code = cdar(x);
+ s_thread_to(sc,OP_BEGIN);
+ } else {/* else */
+ s_save(sc,OP_CASE2, sc->NIL, cdar(x));
+ sc->code = caar(x);
+ s_thread_to(sc,OP_EVAL);
+ }
+ } else {
+ s_return(sc,sc->NIL);
+ }
+
+ CASE(OP_CASE2): /* case */
+ if (is_true(sc->value)) {
+ s_thread_to(sc,OP_BEGIN);
+ } else {
+ s_return(sc,sc->NIL);
+ }
+
+ CASE(OP_PAPPLY): /* apply */
+ sc->code = car(sc->args);
+ sc->args = list_star(sc,cdr(sc->args));
+ /*sc->args = cadr(sc->args);*/
+ s_thread_to(sc,OP_APPLY);
+
+ CASE(OP_PEVAL): /* eval */
+ if(cdr(sc->args)!=sc->NIL) {
+ sc->envir=cadr(sc->args);
+ }
+ sc->code = car(sc->args);
+ s_thread_to(sc,OP_EVAL);
+
+ CASE(OP_CONTINUATION): /* call-with-current-continuation */
+ sc->code = car(sc->args);
+ gc_disable(sc, 2);
+ sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
+ gc_enable(sc);
+ s_thread_to(sc,OP_APPLY);
+
+#if USE_MATH
+ CASE(OP_INEX2EX): /* inexact->exact */
+ x=car(sc->args);
+ if(num_is_integer(x)) {
+ s_return(sc,x);
+ } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
+ s_return(sc,mk_integer(sc,ivalue(x)));
+ } else {
+ Error_1(sc, "inexact->exact: not integral", x);
+ }
+
+ CASE(OP_EXP):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, exp(rvalue(x))));
+
+ CASE(OP_LOG):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, log(rvalue(x))));
+
+ CASE(OP_SIN):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, sin(rvalue(x))));
+
+ CASE(OP_COS):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, cos(rvalue(x))));
+
+ CASE(OP_TAN):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, tan(rvalue(x))));
+
+ CASE(OP_ASIN):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, asin(rvalue(x))));
+
+ CASE(OP_ACOS):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, acos(rvalue(x))));
+
+ CASE(OP_ATAN):
+ x=car(sc->args);
+ if(cdr(sc->args)==sc->NIL) {
+ s_return(sc, mk_real(sc, atan(rvalue(x))));
+ } else {
+ pointer y=cadr(sc->args);
+ s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
+ }
+
+ CASE(OP_SQRT):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, sqrt(rvalue(x))));
+
+ CASE(OP_EXPT): {
+ double result;
+ int real_result=1;
+ pointer y=cadr(sc->args);
+ x=car(sc->args);
+ if (num_is_integer(x) && num_is_integer(y))
+ real_result=0;
+ /* This 'if' is an R5RS compatibility fix. */
+ /* NOTE: Remove this 'if' fix for R6RS. */
+ if (rvalue(x) == 0 && rvalue(y) < 0) {
+ result = 0.0;
+ } else {
+ result = pow(rvalue(x),rvalue(y));
+ }
+ /* Before returning integer result make sure we can. */
+ /* If the test fails, result is too big for integer. */
+ if (!real_result)
+ {
+ long result_as_long = (long)result;
+ if (result != (double)result_as_long)
+ real_result = 1;
+ }
+ if (real_result) {
+ s_return(sc, mk_real(sc, result));
+ } else {
+ s_return(sc, mk_integer(sc, result));
+ }
+ }
+
+ CASE(OP_FLOOR):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, floor(rvalue(x))));
+
+ CASE(OP_CEILING):
+ x=car(sc->args);
+ s_return(sc, mk_real(sc, ceil(rvalue(x))));
+
+ CASE(OP_TRUNCATE ): {
+ double rvalue_of_x ;
+ x=car(sc->args);
+ rvalue_of_x = rvalue(x) ;
+ if (rvalue_of_x > 0) {
+ s_return(sc, mk_real(sc, floor(rvalue_of_x)));
+ } else {
+ s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
+ }
+ }
+
+ CASE(OP_ROUND):
+ x=car(sc->args);
+ if (num_is_integer(x))
+ s_return(sc, x);
+ s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
+#endif
+
+ CASE(OP_ADD): /* + */
+ v=num_zero;
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ v=num_add(v,nvalue(car(x)));
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_MUL): /* * */
+ v=num_one;
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ v=num_mul(v,nvalue(car(x)));
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_SUB): /* - */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_zero;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ v=num_sub(v,nvalue(car(x)));
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_DIV): /* / */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_one;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ if (!is_zero_double(rvalue(car(x))))
+ v=num_div(v,nvalue(car(x)));
+ else {
+ Error_0(sc,"/: division by zero");
+ }
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_INTDIV): /* quotient */
+ if(cdr(sc->args)==sc->NIL) {
+ x=sc->args;
+ v=num_one;
+ } else {
+ x = cdr(sc->args);
+ v = nvalue(car(sc->args));
+ }
+ for (; x != sc->NIL; x = cdr(x)) {
+ if (ivalue(car(x)) != 0)
+ v=num_intdiv(v,nvalue(car(x)));
+ else {
+ Error_0(sc,"quotient: division by zero");
+ }
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_REM): /* remainder */
+ v = nvalue(car(sc->args));
+ if (ivalue(cadr(sc->args)) != 0)
+ v=num_rem(v,nvalue(cadr(sc->args)));
+ else {
+ Error_0(sc,"remainder: division by zero");
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_MOD): /* modulo */
+ v = nvalue(car(sc->args));
+ if (ivalue(cadr(sc->args)) != 0)
+ v=num_mod(v,nvalue(cadr(sc->args)));
+ else {
+ Error_0(sc,"modulo: division by zero");
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_number(sc, v));
+
+ CASE(OP_CAR): /* car */
+ s_return(sc,caar(sc->args));
+
+ CASE(OP_CDR): /* cdr */
+ s_return(sc,cdar(sc->args));
+
+ CASE(OP_CONS): /* cons */
+ cdr(sc->args) = cadr(sc->args);
+ s_return(sc,sc->args);
+
+ CASE(OP_SETCAR): /* set-car! */
+ if(!is_immutable(car(sc->args))) {
+ caar(sc->args) = cadr(sc->args);
+ s_return(sc,car(sc->args));
+ } else {
+ Error_0(sc,"set-car!: unable to alter immutable pair");
+ }
+
+ CASE(OP_SETCDR): /* set-cdr! */
+ if(!is_immutable(car(sc->args))) {
+ cdar(sc->args) = cadr(sc->args);
+ s_return(sc,car(sc->args));
+ } else {
+ Error_0(sc,"set-cdr!: unable to alter immutable pair");
+ }
+
+ CASE(OP_CHAR2INT): { /* char->integer */
+ char c;
+ c=(char)ivalue(car(sc->args));
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_integer(sc, (unsigned char) c));
+ }
+
+ CASE(OP_INT2CHAR): { /* integer->char */
+ unsigned char c;
+ c=(unsigned char)ivalue(car(sc->args));
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_character(sc, (char) c));
+ }
+
+ CASE(OP_CHARUPCASE): {
+ unsigned char c;
+ c=(unsigned char)ivalue(car(sc->args));
+ c=toupper(c);
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_character(sc, (char) c));
+ }
+
+ CASE(OP_CHARDNCASE): {
+ unsigned char c;
+ c=(unsigned char)ivalue(car(sc->args));
+ c=tolower(c);
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_character(sc, (char) c));
+ }
+
+ CASE(OP_STR2SYM): /* string->symbol */
+ gc_disable(sc, gc_reservations (mk_symbol));
+ s_return_enable_gc(sc, mk_symbol(sc, strvalue(car(sc->args))));
+
+ CASE(OP_STR2ATOM): /* string->atom */ {
+ char *s=strvalue(car(sc->args));
+ long pf = 0;
+ if(cdr(sc->args)!=sc->NIL) {
+ /* we know cadr(sc->args) is a natural number */
+ /* see if it is 2, 8, 10, or 16, or error */
+ pf = ivalue_unchecked(cadr(sc->args));
+ if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
+ /* base is OK */
+ }
+ else {
+ pf = -1;
+ }
+ }
+ if (pf < 0) {
+ Error_1(sc, "string->atom: bad base", cadr(sc->args));
+ } else if(*s=='#') /* no use of base! */ {
+ s_return(sc, mk_sharp_const(sc, s+1));
+ } else {
+ if (pf == 0 || pf == 10) {
+ s_return(sc, mk_atom(sc, s));
+ }
+ else {
+ char *ep;
+ long iv = strtol(s,&ep,(int )pf);
+ if (*ep == 0) {
+ s_return(sc, mk_integer(sc, iv));
+ }
+ else {
+ s_return(sc, sc->F);
+ }
+ }
+ }
+ }
+
+ CASE(OP_SYM2STR): /* symbol->string */
+ gc_disable(sc, 1);
+ x=mk_string(sc,symname(car(sc->args)));
+ setimmutable(x);
+ s_return_enable_gc(sc, x);
+
+ CASE(OP_ATOM2STR): /* atom->string */ {
+ long pf = 0;
+ x=car(sc->args);
+ if(cdr(sc->args)!=sc->NIL) {
+ /* we know cadr(sc->args) is a natural number */
+ /* see if it is 2, 8, 10, or 16, or error */
+ pf = ivalue_unchecked(cadr(sc->args));
+ if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
+ /* base is OK */
+ }
+ else {
+ pf = -1;
+ }
+ }
+ if (pf < 0) {
+ Error_1(sc, "atom->string: bad base", cadr(sc->args));
+ } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
+ char *p;
+ int len;
+ atom2str(sc,x,(int )pf,&p,&len);
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_counted_string(sc, p, len));
+ } else {
+ Error_1(sc, "atom->string: not an atom", x);
+ }
+ }
+
+ CASE(OP_MKSTRING): { /* make-string */
+ int fill=' ';
+ int len;
+
+ len=ivalue(car(sc->args));
+
+ if(cdr(sc->args)!=sc->NIL) {
+ fill=charvalue(cadr(sc->args));
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_empty_string(sc, len, (char) fill));
+ }
+
+ CASE(OP_STRLEN): /* string-length */
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_integer(sc, strlength(car(sc->args))));
+
+ CASE(OP_STRREF): { /* string-ref */
+ char *str;
+ int index;
+
+ str=strvalue(car(sc->args));
+
+ index=ivalue(cadr(sc->args));
+
+ if(index>=strlength(car(sc->args))) {
+ Error_1(sc, "string-ref: out of bounds", cadr(sc->args));
+ }
+
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc,
+ mk_character(sc, ((unsigned char*) str)[index]));
+ }
+
+ CASE(OP_STRSET): { /* string-set! */
+ char *str;
+ int index;
+ int c;
+
+ if(is_immutable(car(sc->args))) {
+ Error_1(sc, "string-set!: unable to alter immutable string",
+ car(sc->args));
+ }
+ str=strvalue(car(sc->args));
+
+ index=ivalue(cadr(sc->args));
+ if(index>=strlength(car(sc->args))) {
+ Error_1(sc, "string-set!: out of bounds", cadr(sc->args));
+ }
+
+ c=charvalue(caddr(sc->args));
+
+ str[index]=(char)c;
+ s_return(sc,car(sc->args));
+ }
+
+ CASE(OP_STRAPPEND): { /* string-append */
+ /* in 1.29 string-append was in Scheme in init.scm but was too slow */
+ int len = 0;
+ pointer newstr;
+ char *pos;
+
+ /* compute needed length for new string */
+ for (x = sc->args; x != sc->NIL; x = cdr(x)) {
+ len += strlength(car(x));
+ }
+ gc_disable(sc, 1);
+ newstr = mk_empty_string(sc, len, ' ');
+ /* store the contents of the argument strings into the new string */
+ for (pos = strvalue(newstr), x = sc->args; x != sc->NIL;
+ pos += strlength(car(x)), x = cdr(x)) {
+ memcpy(pos, strvalue(car(x)), strlength(car(x)));
+ }
+ s_return_enable_gc(sc, newstr);
+ }
+
+ CASE(OP_SUBSTR): { /* substring */
+ char *str;
+ int index0;
+ int index1;
+
+ str=strvalue(car(sc->args));
+
+ index0=ivalue(cadr(sc->args));
+
+ if(index0>strlength(car(sc->args))) {
+ Error_1(sc, "substring: start out of bounds", cadr(sc->args));
+ }
+
+ if(cddr(sc->args)!=sc->NIL) {
+ index1=ivalue(caddr(sc->args));
+ if(index1>strlength(car(sc->args)) || index1<index0) {
+ Error_1(sc, "substring: end out of bounds", caddr(sc->args));
+ }
+ } else {
+ index1=strlength(car(sc->args));
+ }
+
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_counted_string(sc, str + index0, index1 - index0));
+ }
+
+ CASE(OP_VECTOR): { /* vector */
+ int i;
+ pointer vec;
+ int len=list_length(sc,sc->args);
+ if(len<0) {
+ Error_1(sc, "vector: not a proper list", sc->args);
+ }
+ vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
+ for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
+ set_vector_elem(vec,i,car(x));
+ }
+ s_return(sc,vec);
+ }
+
+ CASE(OP_MKVECTOR): { /* make-vector */
+ pointer fill=sc->NIL;
+ int len;
+ pointer vec;
+
+ len=ivalue(car(sc->args));
+
+ if(cdr(sc->args)!=sc->NIL) {
+ fill=cadr(sc->args);
+ }
+ vec=mk_vector(sc,len);
+ if(sc->no_memory) { s_return(sc, sc->sink); }
+ if(fill!=sc->NIL) {
+ fill_vector(vec,fill);
+ }
+ s_return(sc,vec);
+ }
+
+ CASE(OP_VECLEN): /* vector-length */
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_integer(sc, vector_length(car(sc->args))));
+
+ CASE(OP_VECREF): { /* vector-ref */
+ int index;
+
+ index=ivalue(cadr(sc->args));
+
+ if(index >= vector_length(car(sc->args))) {
+ Error_1(sc, "vector-ref: out of bounds", cadr(sc->args));
+ }
+
+ s_return(sc,vector_elem(car(sc->args),index));
+ }
+
+ CASE(OP_VECSET): { /* vector-set! */
+ int index;
+
+ if(is_immutable(car(sc->args))) {
+ Error_1(sc, "vector-set!: unable to alter immutable vector",
+ car(sc->args));
+ }
+
+ index=ivalue(cadr(sc->args));
+ if(index >= vector_length(car(sc->args))) {
+ Error_1(sc, "vector-set!: out of bounds", cadr(sc->args));
+ }
+
+ set_vector_elem(car(sc->args),index,caddr(sc->args));
+ s_return(sc,car(sc->args));
+ }
+
+ CASE(OP_NOT): /* not */
+ s_retbool(is_false(car(sc->args)));
+ CASE(OP_BOOLP): /* boolean? */
+ s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
+ CASE(OP_EOFOBJP): /* boolean? */
+ s_retbool(car(sc->args) == sc->EOF_OBJ);
+ CASE(OP_NULLP): /* null? */
+ s_retbool(car(sc->args) == sc->NIL);
+ CASE(OP_NUMEQ): /* = */
+ /* Fallthrough. */
+ CASE(OP_LESS): /* < */
+ /* Fallthrough. */
+ CASE(OP_GRE): /* > */
+ /* Fallthrough. */
+ CASE(OP_LEQ): /* <= */
+ /* Fallthrough. */
+ CASE(OP_GEQ): /* >= */
+ switch(op) {
+ case OP_NUMEQ: comp_func=num_eq; break;
+ case OP_LESS: comp_func=num_lt; break;
+ case OP_GRE: comp_func=num_gt; break;
+ case OP_LEQ: comp_func=num_le; break;
+ case OP_GEQ: comp_func=num_ge; break;
+ default: assert (! "reached");
+ }
+ x=sc->args;
+ v=nvalue(car(x));
+ x=cdr(x);
+
+ for (; x != sc->NIL; x = cdr(x)) {
+ if(!comp_func(v,nvalue(car(x)))) {
+ s_retbool(0);
+ }
+ v=nvalue(car(x));
+ }
+ s_retbool(1);
+ CASE(OP_SYMBOLP): /* symbol? */
+ s_retbool(is_symbol(car(sc->args)));
+ CASE(OP_NUMBERP): /* number? */
+ s_retbool(is_number(car(sc->args)));
+ CASE(OP_STRINGP): /* string? */
+ s_retbool(is_string(car(sc->args)));
+ CASE(OP_INTEGERP): /* integer? */
+ s_retbool(is_integer(car(sc->args)));
+ CASE(OP_REALP): /* real? */
+ s_retbool(is_number(car(sc->args))); /* All numbers are real */
+ CASE(OP_CHARP): /* char? */
+ s_retbool(is_character(car(sc->args)));
+#if USE_CHAR_CLASSIFIERS
+ CASE(OP_CHARAP): /* char-alphabetic? */
+ s_retbool(Cisalpha(ivalue(car(sc->args))));
+ CASE(OP_CHARNP): /* char-numeric? */
+ s_retbool(Cisdigit(ivalue(car(sc->args))));
+ CASE(OP_CHARWP): /* char-whitespace? */
+ s_retbool(Cisspace(ivalue(car(sc->args))));
+ CASE(OP_CHARUP): /* char-upper-case? */
+ s_retbool(Cisupper(ivalue(car(sc->args))));
+ CASE(OP_CHARLP): /* char-lower-case? */
+ s_retbool(Cislower(ivalue(car(sc->args))));
+#endif
+ CASE(OP_PORTP): /* port? */
+ s_retbool(is_port(car(sc->args)));
+ CASE(OP_INPORTP): /* input-port? */
+ s_retbool(is_inport(car(sc->args)));
+ CASE(OP_OUTPORTP): /* output-port? */
+ s_retbool(is_outport(car(sc->args)));
+ CASE(OP_PROCP): /* procedure? */
+ /*--
+ * continuation should be procedure by the example
+ * (call-with-current-continuation procedure?) ==> #t
+ * in R^3 report sec. 6.9
+ */
+ s_retbool(is_proc(car(sc->args)) || is_closure(car(sc->args))
+ || is_continuation(car(sc->args)) || is_foreign(car(sc->args)));
+ CASE(OP_PAIRP): /* pair? */
+ s_retbool(is_pair(car(sc->args)));
+ CASE(OP_LISTP): /* list? */
+ s_retbool(list_length(sc,car(sc->args)) >= 0);
+
+ CASE(OP_ENVP): /* environment? */
+ s_retbool(is_environment(car(sc->args)));
+ CASE(OP_VECTORP): /* vector? */
+ s_retbool(is_vector(car(sc->args)));
+ CASE(OP_EQ): /* eq? */
+ s_retbool(car(sc->args) == cadr(sc->args));
+ CASE(OP_EQV): /* eqv? */
+ s_retbool(eqv(car(sc->args), cadr(sc->args)));
+
+ CASE(OP_FORCE): /* force */
+ sc->code = car(sc->args);
+ if (is_promise(sc->code)) {
+ /* Should change type to closure here */
+ s_save(sc, OP_SAVE_FORCED, sc->NIL, sc->code);
+ sc->args = sc->NIL;
+ s_thread_to(sc,OP_APPLY);
+ } else {
+ s_return(sc,sc->code);
+ }
+
+ CASE(OP_SAVE_FORCED): /* Save forced value replacing promise */
+ copy_value(sc, sc->code, sc->value);
+ s_return(sc,sc->value);
+
+ CASE(OP_WRITE): /* write */
+ /* Fallthrough. */
+ CASE(OP_DISPLAY): /* display */
+ /* Fallthrough. */
+ CASE(OP_WRITE_CHAR): /* write-char */
+ if(is_pair(cdr(sc->args))) {
+ if(cadr(sc->args)!=sc->outport) {
+ x=cons(sc,sc->outport,sc->NIL);
+ s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
+ sc->outport=cadr(sc->args);
+ }
+ }
+ sc->args = car(sc->args);
+ if(op==OP_WRITE) {
+ sc->print_flag = 1;
+ } else {
+ sc->print_flag = 0;
+ }
+ s_thread_to(sc,OP_P0LIST);
+
+ CASE(OP_NEWLINE): /* newline */
+ if(is_pair(sc->args)) {
+ if(car(sc->args)!=sc->outport) {
+ x=cons(sc,sc->outport,sc->NIL);
+ s_save(sc,OP_SET_OUTPORT, x, sc->NIL);
+ sc->outport=car(sc->args);
+ }
+ }
+ putstr(sc, "\n");
+ s_return(sc,sc->T);
+
+ CASE(OP_ERR0): /* error */
+ sc->retcode=-1;
+ if (!is_string(car(sc->args))) {
+ sc->args=cons(sc,mk_string(sc," -- "),sc->args);
+ setimmutable(car(sc->args));
+ }
+ putstr(sc, "Error: ");
+ putstr(sc, strvalue(car(sc->args)));
+ sc->args = cdr(sc->args);
+ s_thread_to(sc,OP_ERR1);
+
+ CASE(OP_ERR1): /* error */
+ putstr(sc, " ");
+ if (sc->args != sc->NIL) {
+ s_save(sc,OP_ERR1, cdr(sc->args), sc->NIL);
+ sc->args = car(sc->args);
+ sc->print_flag = 1;
+ s_thread_to(sc,OP_P0LIST);
+ } else {
+ putstr(sc, "\n");
+ if(sc->interactive_repl) {
+ s_thread_to(sc,OP_T0LVL);
+ } else {
+ return;
+ }
+ }
+
+ CASE(OP_REVERSE): /* reverse */
+ s_return(sc,reverse(sc, sc->NIL, car(sc->args)));
+
+ CASE(OP_REVERSE_IN_PLACE): /* reverse! */
+ s_return(sc, reverse_in_place(sc, sc->NIL, car(sc->args)));
+
+ CASE(OP_LIST_STAR): /* list* */
+ s_return(sc,list_star(sc,sc->args));
+
+ CASE(OP_APPEND): /* append */
+ x = sc->NIL;
+ y = sc->args;
+ if (y == x) {
+ s_return(sc, x);
+ }
+
+ /* cdr() in the while condition is not a typo. If car() */
+ /* is used (append '() 'a) will return the wrong result.*/
+ while (cdr(y) != sc->NIL) {
+ x = revappend(sc, x, car(y));
+ y = cdr(y);
+ if (x == sc->F) {
+ Error_0(sc, "non-list argument to append");
+ }
+ }
+
+ s_return(sc, reverse_in_place(sc, car(y), x));
+
+#if USE_PLIST
+ CASE(OP_SET_SYMBOL_PROPERTY): /* set-symbol-property! */
+ gc_disable(sc, gc_reservations(set_property));
+ s_return_enable_gc(sc,
+ set_property(sc, car(sc->args),
+ cadr(sc->args), caddr(sc->args)));
+
+ CASE(OP_SYMBOL_PROPERTY): /* symbol-property */
+ s_return(sc, get_property(sc, car(sc->args), cadr(sc->args)));
+#endif /* USE_PLIST */
+
+ CASE(OP_TAG_VALUE): { /* not exposed */
+ /* This tags sc->value with car(sc->args). Useful to tag
+ * results of opcode evaluations. */
+ pointer a, b, c;
+ free_cons(sc, sc->args, &a, &b);
+ free_cons(sc, b, &b, &c);
+ assert(c == sc->NIL);
+ s_return(sc, mk_tagged_value(sc, sc->value, a, b));
+ }
+
+ CASE(OP_MK_TAGGED): /* make-tagged-value */
+ if (is_vector(car(sc->args)))
+ Error_0(sc, "cannot tag vector");
+ s_return(sc, mk_tagged_value(sc, car(sc->args),
+ car(cadr(sc->args)),
+ cdr(cadr(sc->args))));
+
+ CASE(OP_GET_TAG): /* get-tag */
+ s_return(sc, get_tag(sc, car(sc->args)));
+
+ CASE(OP_QUIT): /* quit */
+ if(is_pair(sc->args)) {
+ sc->retcode=ivalue(car(sc->args));
+ }
+ return;
+
+ CASE(OP_GC): /* gc */
+ gc(sc, sc->NIL, sc->NIL);
+ s_return(sc,sc->T);
+
+ CASE(OP_GCVERB): /* gc-verbose */
+ { int was = sc->gc_verbose;
+
+ sc->gc_verbose = (car(sc->args) != sc->F);
+ s_retbool(was);
+ }
+
+ CASE(OP_NEWSEGMENT): /* new-segment */
+ if (!is_pair(sc->args) || !is_number(car(sc->args))) {
+ Error_0(sc,"new-segment: argument must be a number");
+ }
+ alloc_cellseg(sc, (int) ivalue(car(sc->args)));
+ s_return(sc,sc->T);
+
+ CASE(OP_OBLIST): /* oblist */
+ s_return(sc, oblist_all_symbols(sc));
+
+ CASE(OP_CURR_INPORT): /* current-input-port */
+ s_return(sc,sc->inport);
+
+ CASE(OP_CURR_OUTPORT): /* current-output-port */
+ s_return(sc,sc->outport);
+
+ CASE(OP_OPEN_INFILE): /* open-input-file */
+ /* Fallthrough. */
+ CASE(OP_OPEN_OUTFILE): /* open-output-file */
+ /* Fallthrough. */
+ CASE(OP_OPEN_INOUTFILE): /* open-input-output-file */ {
+ int prop=0;
+ pointer p;
+ switch(op) {
+ case OP_OPEN_INFILE: prop=port_input; break;
+ case OP_OPEN_OUTFILE: prop=port_output; break;
+ case OP_OPEN_INOUTFILE: prop=port_input|port_output; break;
+ default: assert (! "reached");
+ }
+ p=port_from_filename(sc,strvalue(car(sc->args)),prop);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_return(sc,p);
+ break;
+ }
+
+#if USE_STRING_PORTS
+ CASE(OP_OPEN_INSTRING): /* open-input-string */
+ /* Fallthrough. */
+ CASE(OP_OPEN_INOUTSTRING): /* open-input-output-string */ {
+ int prop=0;
+ pointer p;
+ switch(op) {
+ case OP_OPEN_INSTRING: prop=port_input; break;
+ case OP_OPEN_INOUTSTRING: prop=port_input|port_output; break;
+ default: assert (! "reached");
+ }
+ p=port_from_string(sc, strvalue(car(sc->args)),
+ strvalue(car(sc->args))+strlength(car(sc->args)), prop);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ s_return(sc,p);
+ }
+ CASE(OP_OPEN_OUTSTRING): /* open-output-string */ {
+ pointer p;
+ if(car(sc->args)==sc->NIL) {
+ p=port_from_scratch(sc);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ } else {
+ p=port_from_string(sc, strvalue(car(sc->args)),
+ strvalue(car(sc->args))+strlength(car(sc->args)),
+ port_output);
+ if(p==sc->NIL) {
+ s_return(sc,sc->F);
+ }
+ }
+ s_return(sc,p);
+ }
+ CASE(OP_GET_OUTSTRING): /* get-output-string */ {
+ port *p;
+
+ if ((p=car(sc->args)->_object._port)->kind&port_string) {
+ gc_disable(sc, 1);
+ s_return_enable_gc(
+ sc,
+ mk_counted_string(sc,
+ p->rep.string.start,
+ p->rep.string.curr - p->rep.string.start));
+ }
+ s_return(sc,sc->F);
+ }
+#endif
+
+ CASE(OP_CLOSE_INPORT): /* close-input-port */
+ port_close(sc,car(sc->args),port_input);
+ s_return(sc,sc->T);
+
+ CASE(OP_CLOSE_OUTPORT): /* close-output-port */
+ port_close(sc,car(sc->args),port_output);
+ s_return(sc,sc->T);
+
+ CASE(OP_INT_ENV): /* interaction-environment */
+ s_return(sc,sc->global_env);
+
+ CASE(OP_CURR_ENV): /* current-environment */
+ s_return(sc,sc->envir);
+
+
+ /* ========== reading part ========== */
+ CASE(OP_READ):
+ if(!is_pair(sc->args)) {
+ s_thread_to(sc,OP_READ_INTERNAL);
+ }
+ if(!is_inport(car(sc->args))) {
+ Error_1(sc, "read: not an input port", car(sc->args));
+ }
+ if(car(sc->args)==sc->inport) {
+ s_thread_to(sc,OP_READ_INTERNAL);
+ }
+ x=sc->inport;
+ sc->inport=car(sc->args);
+ x=cons(sc,x,sc->NIL);
+ s_save(sc,OP_SET_INPORT, x, sc->NIL);
+ s_thread_to(sc,OP_READ_INTERNAL);
+
+ CASE(OP_READ_CHAR): /* read-char */
+ /* Fallthrough. */
+ CASE(OP_PEEK_CHAR): /* peek-char */ {
+ int c;
+ if(is_pair(sc->args)) {
+ if(car(sc->args)!=sc->inport) {
+ x=sc->inport;
+ x=cons(sc,x,sc->NIL);
+ s_save(sc,OP_SET_INPORT, x, sc->NIL);
+ sc->inport=car(sc->args);
+ }
+ }
+ c=inchar(sc);
+ if(c==EOF) {
+ s_return(sc,sc->EOF_OBJ);
+ }
+ if(op==OP_PEEK_CHAR) {
+ backchar(sc,c);
+ }
+ s_return(sc,mk_character(sc,c));
+ }
+
+ CASE(OP_CHAR_READY): /* char-ready? */ {
+ pointer p=sc->inport;
+ int res;
+ if(is_pair(sc->args)) {
+ p=car(sc->args);
+ }
+ res=p->_object._port->kind&port_string;
+ s_retbool(res);
+ }
+
+ CASE(OP_SET_INPORT): /* set-input-port */
+ sc->inport=car(sc->args);
+ s_return(sc,sc->value);
+
+ CASE(OP_SET_OUTPORT): /* set-output-port */
+ sc->outport=car(sc->args);
+ s_return(sc,sc->value);
+
+ CASE(OP_RDSEXPR):
+ switch (sc->tok) {
+ case TOK_EOF:
+ s_return(sc,sc->EOF_OBJ);
+ /* NOTREACHED */
+ case TOK_VEC:
+ s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
+ /* fall through */
+ case TOK_LPAREN:
+ sc->tok = token(sc);
+ if (sc->tok == TOK_RPAREN) {
+ s_return(sc,sc->NIL);
+ } else if (sc->tok == TOK_DOT) {
+ Error_0(sc,"syntax error: illegal dot expression");
+ } else {
+#if SHOW_ERROR_LINE
+ pointer filename;
+ pointer lineno;
+#endif
+ sc->nesting_stack[sc->file_i]++;
+#if SHOW_ERROR_LINE
+ filename = sc->load_stack[sc->file_i].filename;
+ lineno = sc->load_stack[sc->file_i].curr_line;
+
+ s_save(sc, OP_TAG_VALUE,
+ cons(sc, filename, cons(sc, lineno, sc->NIL)),
+ sc->NIL);
+#endif
+ s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
+ s_thread_to(sc,OP_RDSEXPR);
+ }
+ case TOK_QUOTE:
+ s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_thread_to(sc,OP_RDSEXPR);
+ case TOK_BQUOTE:
+ sc->tok = token(sc);
+ if(sc->tok==TOK_VEC) {
+ s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
+ sc->tok=TOK_LPAREN;
+ s_thread_to(sc,OP_RDSEXPR);
+ } else {
+ s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
+ }
+ s_thread_to(sc,OP_RDSEXPR);
+ case TOK_COMMA:
+ s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_thread_to(sc,OP_RDSEXPR);
+ case TOK_ATMARK:
+ s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
+ sc->tok = token(sc);
+ s_thread_to(sc,OP_RDSEXPR);
+ case TOK_ATOM:
+ s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
+ case TOK_DQUOTE:
+ x=readstrexp(sc);
+ if(x==sc->F) {
+ Error_0(sc,"Error reading string");
+ }
+ setimmutable(x);
+ s_return(sc,x);
+ case TOK_SHARP: {
+ pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
+ if(f==sc->NIL) {
+ Error_0(sc,"undefined sharp expression");
+ } else {
+ sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
+ s_thread_to(sc,OP_EVAL);
+ }
+ }
+ case TOK_SHARP_CONST:
+ if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
+ Error_0(sc,"undefined sharp expression");
+ } else {
+ s_return(sc,x);
+ }
+ default:
+ Error_0(sc,"syntax error: illegal token");
+ }
+ break;
+
+ CASE(OP_RDLIST): {
+ gc_disable(sc, 1);
+ sc->args = cons(sc, sc->value, sc->args);
+ gc_enable(sc);
+ sc->tok = token(sc);
+ if (sc->tok == TOK_EOF)
+ { s_return(sc,sc->EOF_OBJ); }
+ else if (sc->tok == TOK_RPAREN) {
+ int c = inchar(sc);
+ if (c != '\n')
+ backchar(sc,c);
+ else
+ port_increment_current_line(sc, &sc->load_stack[sc->file_i], 1);
+ sc->nesting_stack[sc->file_i]--;
+ s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
+ } else if (sc->tok == TOK_DOT) {
+ s_save(sc,OP_RDDOT, sc->args, sc->NIL);
+ sc->tok = token(sc);
+ s_thread_to(sc,OP_RDSEXPR);
+ } else {
+ s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
+ s_thread_to(sc,OP_RDSEXPR);
+ }
+ }
+
+ CASE(OP_RDDOT):
+ if (token(sc) != TOK_RPAREN) {
+ Error_0(sc,"syntax error: illegal dot expression");
+ } else {
+ sc->nesting_stack[sc->file_i]--;
+ s_return(sc,reverse_in_place(sc, sc->value, sc->args));
+ }
+
+ CASE(OP_RDQUOTE):
+ gc_disable(sc, 2);
+ s_return_enable_gc(sc, cons(sc, sc->QUOTE,
+ cons(sc, sc->value, sc->NIL)));
+
+ CASE(OP_RDQQUOTE):
+ gc_disable(sc, 2);
+ s_return_enable_gc(sc, cons(sc, sc->QQUOTE,
+ cons(sc, sc->value, sc->NIL)));
+
+ CASE(OP_RDQQUOTEVEC):
+ gc_disable(sc, 5 + 2 * gc_reservations (mk_symbol));
+ s_return_enable_gc(sc,cons(sc, mk_symbol(sc,"apply"),
+ cons(sc, mk_symbol(sc,"vector"),
+ cons(sc,cons(sc, sc->QQUOTE,
+ cons(sc,sc->value,sc->NIL)),
+ sc->NIL))));
+
+ CASE(OP_RDUNQUOTE):
+ gc_disable(sc, 2);
+ s_return_enable_gc(sc, cons(sc, sc->UNQUOTE,
+ cons(sc, sc->value, sc->NIL)));
+
+ CASE(OP_RDUQTSP):
+ gc_disable(sc, 2);
+ s_return_enable_gc(sc, cons(sc, sc->UNQUOTESP,
+ cons(sc, sc->value, sc->NIL)));
+
+ CASE(OP_RDVEC):
+ /*sc->code=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
+ s_thread_to(sc,OP_EVAL); Cannot be quoted*/
+ /*x=cons(sc,mk_proc(sc,OP_VECTOR),sc->value);
+ s_return(sc,x); Cannot be part of pairs*/
+ /*sc->code=mk_proc(sc,OP_VECTOR);
+ sc->args=sc->value;
+ s_thread_to(sc,OP_APPLY);*/
+ sc->args=sc->value;
+ s_thread_to(sc,OP_VECTOR);
+
+ /* ========== printing part ========== */
+ CASE(OP_P0LIST):
+ if(is_vector(sc->args)) {
+ putstr(sc,"#(");
+ sc->args=cons(sc,sc->args,mk_integer(sc,0));
+ s_thread_to(sc,OP_PVECFROM);
+ } else if(is_environment(sc->args)) {
+ putstr(sc,"#<ENVIRONMENT>");
+ s_return(sc,sc->T);
+ } else if (!is_pair(sc->args)) {
+ printatom(sc, sc->args, sc->print_flag);
+ s_return(sc,sc->T);
+ } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, "'");
+ sc->args = cadr(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, "`");
+ sc->args = cadr(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, ",");
+ sc->args = cadr(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
+ putstr(sc, ",@");
+ sc->args = cadr(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ } else {
+ putstr(sc, "(");
+ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
+ sc->args = car(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ }
+
+ CASE(OP_P1LIST):
+ if (is_pair(sc->args)) {
+ s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
+ putstr(sc, " ");
+ sc->args = car(sc->args);
+ s_thread_to(sc,OP_P0LIST);
+ } else if(is_vector(sc->args)) {
+ s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
+ putstr(sc, " . ");
+ s_thread_to(sc,OP_P0LIST);
+ } else {
+ if (sc->args != sc->NIL) {
+ putstr(sc, " . ");
+ printatom(sc, sc->args, sc->print_flag);
+ }
+ putstr(sc, ")");
+ s_return(sc,sc->T);
+ }
+ CASE(OP_PVECFROM): {
+ int i=ivalue_unchecked(cdr(sc->args));
+ pointer vec=car(sc->args);
+ int len = vector_length(vec);
+ if(i==len) {
+ putstr(sc,")");
+ s_return(sc,sc->T);
+ } else {
+ pointer elem=vector_elem(vec,i);
+ cdr(sc->args) = mk_integer(sc, i + 1);
+ s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
+ sc->args=elem;
+ if (i > 0)
+ putstr(sc," ");
+ s_thread_to(sc,OP_P0LIST);
+ }
+ }
+
+ CASE(OP_LIST_LENGTH): { /* length */ /* a.k */
+ long l = list_length(sc, car(sc->args));
+ if(l<0) {
+ Error_1(sc, "length: not a list", car(sc->args));
+ }
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, mk_integer(sc, l));
+ }
+ CASE(OP_ASSQ): /* assq */ /* a.k */
+ x = car(sc->args);
+ for (y = cadr(sc->args); is_pair(y); y = cdr(y)) {
+ if (!is_pair(car(y))) {
+ Error_0(sc,"unable to handle non pair element");
+ }
+ if (x == caar(y))
+ break;
+ }
+ if (is_pair(y)) {
+ s_return(sc,car(y));
+ } else {
+ s_return(sc,sc->F);
+ }
+
+
+ CASE(OP_GET_CLOSURE): /* get-closure-code */ /* a.k */
+ sc->args = car(sc->args);
+ if (sc->args == sc->NIL) {
+ s_return(sc,sc->F);
+ } else if (is_closure(sc->args)) {
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+ closure_code(sc->value)));
+ } else if (is_macro(sc->args)) {
+ gc_disable(sc, 1);
+ s_return_enable_gc(sc, cons(sc, sc->LAMBDA,
+ closure_code(sc->value)));
+ } else {
+ s_return(sc,sc->F);
+ }
+ CASE(OP_CLOSUREP): /* closure? */
+ /*
+ * Note, macro object is also a closure.
+ * Therefore, (closure? <#MACRO>) ==> #t
+ */
+ s_retbool(is_closure(car(sc->args)));
+ CASE(OP_MACROP): /* macro? */
+ s_retbool(is_macro(car(sc->args)));
+ CASE(OP_VM_HISTORY): /* *vm-history* */
+ s_return(sc, history_flatten(sc));
+ default:
+ snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", op);
+ Error_0(sc,sc->strbuff);
+ }
+ }
+}
+
+#if GPGRT_GCC_VERSION >= 80000
+# pragma GCC diagnostic pop
+#endif
+
+
+typedef int (*test_predicate)(pointer);
+
+static int is_any(pointer p) {
+ (void)p;
+ return 1;
+}
+
+static int is_nonneg(pointer p) {
+ return ivalue(p)>=0 && is_integer(p);
+}
+
+/* Correspond carefully with following defines! */
+static const struct {
+ test_predicate fct;
+ const char *kind;
+} tests[]={
+ {0,0}, /* unused */
+ {is_any, 0},
+ {is_string, "string"},
+ {is_symbol, "symbol"},
+ {is_port, "port"},
+ {is_inport,"input port"},
+ {is_outport,"output port"},
+ {is_environment, "environment"},
+ {is_pair, "pair"},
+ {0, "pair or '()"},
+ {is_character, "character"},
+ {is_vector, "vector"},
+ {is_number, "number"},
+ {is_integer, "integer"},
+ {is_nonneg, "non-negative integer"}
+};
+
+#define TST_NONE 0
+#define TST_ANY "\001"
+#define TST_STRING "\002"
+#define TST_SYMBOL "\003"
+#define TST_PORT "\004"
+#define TST_INPORT "\005"
+#define TST_OUTPORT "\006"
+#define TST_ENVIRONMENT "\007"
+#define TST_PAIR "\010"
+#define TST_LIST "\011"
+#define TST_CHAR "\012"
+#define TST_VECTOR "\013"
+#define TST_NUMBER "\014"
+#define TST_INTEGER "\015"
+#define TST_NATURAL "\016"
+
+#define INF_ARG 0xff
+
+static const struct op_code_info dispatch_table[]= {
+#define _OP_DEF(A,B,C,D,OP) {{A},B,C,{D}},
+#include "opdefines.h"
+#undef _OP_DEF
+ {{0},0,0,{0}},
+};
+
+static const char *procname(pointer x) {
+ int n=procnum(x);
+ const char *name=dispatch_table[n].name;
+ if (name[0] == 0) {
+ name="ILLEGAL!";
+ }
+ return name;
+}
+
+static int
+check_arguments (scheme *sc, const struct op_code_info *pcd, char *msg, size_t msg_size)
+{
+ int ok = 1;
+ int n = list_length(sc, sc->args);
+
+ /* Check number of arguments */
+ if (n < pcd->min_arity) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity == pcd->max_arity ? "" : " at least",
+ pcd->min_arity);
+ }
+ if (ok && n>pcd->max_arity) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: needs%s %d argument(s)",
+ pcd->name,
+ pcd->min_arity == pcd->max_arity ? "" : " at most",
+ pcd->max_arity);
+ }
+ if (ok) {
+ if (pcd->arg_tests_encoding[0] != 0) {
+ int i = 0;
+ int j;
+ const char *t = pcd->arg_tests_encoding;
+ pointer arglist = sc->args;
+
+ do {
+ pointer arg = car(arglist);
+ j = (int)t[0];
+ if (j == TST_LIST[0]) {
+ if (arg != sc->NIL && !is_pair(arg)) break;
+ } else {
+ if (!tests[j].fct(arg)) break;
+ }
+
+ if (t[1] != 0 && i < sizeof pcd->arg_tests_encoding) {
+ /* last test is replicated as necessary */
+ t++;
+ }
+ arglist = cdr(arglist);
+ i++;
+ } while (i < n);
+
+ if (i < n) {
+ ok = 0;
+ snprintf(msg, msg_size, "%s: argument %d must be: %s, got: %s",
+ pcd->name,
+ i + 1,
+ tests[j].kind,
+ type_to_string(type(car(arglist))));
+ }
+ }
+ }
+
+ return ok;
+}
+
+/* ========== Initialization of internal keywords ========== */
+
+/* Symbols representing syntax are tagged with (OP . '()). */
+static void assign_syntax(scheme *sc, enum scheme_opcodes op, char *name) {
+ pointer x, y;
+ pointer *slot;
+
+ x = oblist_find_by_name(sc, name, &slot);
+ assert (x == sc->NIL);
+
+ x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
+ typeflag(x) = T_SYMBOL | T_SYNTAX;
+ setimmutable(car(x));
+ y = mk_tagged_value(sc, x, mk_integer(sc, op), sc->NIL);
+ free_cell(sc, x);
+ setimmutable(get_tag(sc, y));
+ *slot = immutable_cons(sc, y, *slot);
+}
+
+/* Returns the opcode for the syntax represented by P. */
+static int syntaxnum(scheme *sc, pointer p) {
+ int op = ivalue_unchecked(car(get_tag(sc, p)));
+ assert (op < OP_MAXDEFINED);
+ return op;
+}
+
+static void assign_proc(scheme *sc, enum scheme_opcodes op, const char *name) {
+ pointer x, y;
+
+ x = mk_symbol(sc, name);
+ y = mk_proc(sc,op);
+ new_slot_in_env(sc, x, y);
+}
+
+static pointer mk_proc(scheme *sc, enum scheme_opcodes op) {
+ pointer y;
+
+ y = get_cell(sc, sc->NIL, sc->NIL);
+ typeflag(y) = (T_PROC | T_ATOM);
+ ivalue_unchecked(y) = (long) op;
+ set_num_integer(y);
+ return y;
+}
+
+/* initialization of TinyScheme */
+#if USE_INTERFACE
+INTERFACE static pointer s_cons(scheme *sc, pointer a, pointer b) {
+ return cons(sc,a,b);
+}
+INTERFACE static pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
+ return immutable_cons(sc,a,b);
+}
+
+static const struct scheme_interface vtbl = {
+ scheme_define,
+ s_cons,
+ s_immutable_cons,
+ reserve_cells,
+ mk_integer,
+ mk_real,
+ mk_symbol,
+ gensym,
+ mk_string,
+ mk_counted_string,
+ mk_character,
+ mk_vector,
+ mk_foreign_func,
+ mk_foreign_object,
+ get_foreign_object_vtable,
+ get_foreign_object_data,
+ putstr,
+ putcharacter,
+
+ is_string,
+ string_value,
+ is_number,
+ nvalue,
+ ivalue,
+ rvalue,
+ is_integer,
+ is_real,
+ is_character,
+ charvalue,
+ is_list,
+ is_vector,
+ list_length,
+ ivalue,
+ fill_vector,
+ vector_elem,
+ set_vector_elem,
+ is_port,
+ is_pair,
+ pair_car,
+ pair_cdr,
+ set_car,
+ set_cdr,
+
+ is_symbol,
+ symname,
+
+ is_syntax,
+ is_proc,
+ is_foreign,
+ syntaxname,
+ is_closure,
+ is_macro,
+ closure_code,
+ closure_env,
+
+ is_continuation,
+ is_promise,
+ is_environment,
+ is_immutable,
+ setimmutable,
+
+ scheme_load_file,
+ scheme_load_string,
+ port_from_file
+};
+#endif
+
+scheme *scheme_init_new() {
+ scheme *sc=(scheme*)malloc(sizeof(scheme));
+ if(!scheme_init(sc)) {
+ free(sc);
+ return 0;
+ } else {
+ return sc;
+ }
+}
+
+scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
+ scheme *sc=(scheme*)malloc(sizeof(scheme));
+ if(!scheme_init_custom_alloc(sc,malloc,free)) {
+ free(sc);
+ return 0;
+ } else {
+ return sc;
+ }
+}
+
+
+int scheme_init(scheme *sc) {
+ return scheme_init_custom_alloc(sc,malloc,free);
+}
+
+int scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
+ int i, n=sizeof(dispatch_table)/sizeof(dispatch_table[0]);
+ pointer x;
+
+#if USE_INTERFACE
+ sc->vptr=&vtbl;
+#endif
+ sc->gensym_cnt=0;
+ sc->malloc=malloc;
+ sc->free=free;
+ sc->sink = &sc->_sink;
+ sc->NIL = &sc->_NIL;
+ sc->T = &sc->_HASHT;
+ sc->F = &sc->_HASHF;
+ sc->EOF_OBJ=&sc->_EOF_OBJ;
+
+ sc->free_cell = &sc->_NIL;
+ sc->fcells = 0;
+ sc->inhibit_gc = GC_ENABLED;
+ sc->reserved_cells = 0;
+#ifndef NDEBUG
+ sc->reserved_lineno = 0;
+#endif
+ sc->no_memory=0;
+ sc->inport=sc->NIL;
+ sc->outport=sc->NIL;
+ sc->save_inport=sc->NIL;
+ sc->loadport=sc->NIL;
+ sc->nesting=0;
+ memset (sc->nesting_stack, 0, sizeof sc->nesting_stack);
+ sc->interactive_repl=0;
+ sc->strbuff = sc->malloc(STRBUFFSIZE);
+ if (sc->strbuff == 0) {
+ sc->no_memory=1;
+ return 0;
+ }
+ sc->strbuff_size = STRBUFFSIZE;
+
+ sc->cell_segments = NULL;
+ if (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
+ sc->no_memory=1;
+ return 0;
+ }
+ sc->gc_verbose = 0;
+ dump_stack_initialize(sc);
+ sc->code = sc->NIL;
+ sc->tracing=0;
+ sc->flags = 0;
+
+ /* init sc->NIL */
+ typeflag(sc->NIL) = (T_NIL | T_ATOM | MARK);
+ car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
+ /* init T */
+ typeflag(sc->T) = (T_BOOLEAN | T_ATOM | MARK);
+ car(sc->T) = cdr(sc->T) = sc->T;
+ /* init F */
+ typeflag(sc->F) = (T_BOOLEAN | T_ATOM | MARK);
+ car(sc->F) = cdr(sc->F) = sc->F;
+ /* init EOF_OBJ */
+ typeflag(sc->EOF_OBJ) = (T_EOF_OBJ | T_ATOM | MARK);
+ car(sc->EOF_OBJ) = cdr(sc->EOF_OBJ) = sc->EOF_OBJ;
+ /* init sink */
+ typeflag(sc->sink) = (T_SINK | T_PAIR | MARK);
+ car(sc->sink) = cdr(sc->sink) = sc->NIL;
+ /* init c_nest */
+ sc->c_nest = sc->NIL;
+
+ sc->oblist = oblist_initial_value(sc);
+ /* init global_env */
+ new_frame_in_env(sc, sc->NIL);
+ sc->global_env = sc->envir;
+ /* init else */
+ x = mk_symbol(sc,"else");
+ new_slot_in_env(sc, x, sc->T);
+
+ assign_syntax(sc, OP_LAMBDA, "lambda");
+ assign_syntax(sc, OP_QUOTE, "quote");
+ assign_syntax(sc, OP_DEF0, "define");
+ assign_syntax(sc, OP_IF0, "if");
+ assign_syntax(sc, OP_BEGIN, "begin");
+ assign_syntax(sc, OP_SET0, "set!");
+ assign_syntax(sc, OP_LET0, "let");
+ assign_syntax(sc, OP_LET0AST, "let*");
+ assign_syntax(sc, OP_LET0REC, "letrec");
+ assign_syntax(sc, OP_COND0, "cond");
+ assign_syntax(sc, OP_DELAY, "delay");
+ assign_syntax(sc, OP_AND0, "and");
+ assign_syntax(sc, OP_OR0, "or");
+ assign_syntax(sc, OP_C0STREAM, "cons-stream");
+ assign_syntax(sc, OP_MACRO0, "macro");
+ assign_syntax(sc, OP_CASE0, "case");
+
+ for(i=0; i<n; i++) {
+ if (dispatch_table[i].name[0] != 0) {
+ assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
+ }
+ }
+
+ history_init(sc, 8, 8);
+
+ /* initialization of global pointers to special symbols */
+ sc->LAMBDA = mk_symbol(sc, "lambda");
+ sc->QUOTE = mk_symbol(sc, "quote");
+ sc->QQUOTE = mk_symbol(sc, "quasiquote");
+ sc->UNQUOTE = mk_symbol(sc, "unquote");
+ sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
+ sc->FEED_TO = mk_symbol(sc, "=>");
+ sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
+ sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
+ sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
+#if USE_COMPILE_HOOK
+ sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
+#endif
+
+ return !sc->no_memory;
+}
+
+void scheme_set_input_port_file(scheme *sc, FILE *fin) {
+ sc->inport=port_from_file(sc,fin,port_input);
+}
+
+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end) {
+ sc->inport=port_from_string(sc,start,past_the_end,port_input);
+}
+
+void scheme_set_output_port_file(scheme *sc, FILE *fout) {
+ sc->outport=port_from_file(sc,fout,port_output);
+}
+
+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end) {
+ sc->outport=port_from_string(sc,start,past_the_end,port_output);
+}
+
+void scheme_set_external_data(scheme *sc, void *p) {
+ sc->ext_data=p;
+}
+
+void scheme_deinit(scheme *sc) {
+ struct cell_segment *s;
+ int i;
+
+ sc->oblist=sc->NIL;
+ sc->global_env=sc->NIL;
+ dump_stack_free(sc);
+ sc->envir=sc->NIL;
+ sc->code=sc->NIL;
+ history_free(sc);
+ sc->args=sc->NIL;
+ sc->value=sc->NIL;
+ if(is_port(sc->inport)) {
+ typeflag(sc->inport) = T_ATOM;
+ }
+ sc->inport=sc->NIL;
+ sc->outport=sc->NIL;
+ if(is_port(sc->save_inport)) {
+ typeflag(sc->save_inport) = T_ATOM;
+ }
+ sc->save_inport=sc->NIL;
+ if(is_port(sc->loadport)) {
+ typeflag(sc->loadport) = T_ATOM;
+ }
+ sc->loadport=sc->NIL;
+
+ for(i=0; i<=sc->file_i; i++) {
+ port_clear_location(sc, &sc->load_stack[i]);
+ }
+
+ sc->gc_verbose=0;
+ gc(sc,sc->NIL,sc->NIL);
+
+ for (s = sc->cell_segments; s; s = _dealloc_cellseg(sc, s)) {
+ /* nop */
+ }
+ sc->free(sc->strbuff);
+}
+
+void scheme_load_file(scheme *sc, FILE *fin)
+{ scheme_load_named_file(sc,fin,0); }
+
+void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename) {
+ dump_stack_reset(sc);
+ sc->envir = sc->global_env;
+ sc->file_i=0;
+ sc->load_stack[0].kind=port_input|port_file;
+ sc->load_stack[0].rep.stdio.file=fin;
+ sc->loadport=mk_port(sc,sc->load_stack);
+ sc->retcode=0;
+ if(fin==stdin) {
+ sc->interactive_repl=1;
+ }
+
+ port_init_location(sc, &sc->load_stack[0],
+ (fin != stdin && filename)
+ ? mk_string(sc, filename)
+ : NULL);
+
+ sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
+ Eval_Cycle(sc, OP_T0LVL);
+ typeflag(sc->loadport)=T_ATOM;
+ if(sc->retcode==0) {
+ sc->retcode=sc->nesting!=0;
+ }
+
+ port_clear_location(sc, &sc->load_stack[0]);
+}
+
+void scheme_load_string(scheme *sc, const char *cmd) {
+ scheme_load_memory(sc, cmd, strlen(cmd), NULL);
+}
+
+void scheme_load_memory(scheme *sc, const char *buf, size_t len, const char *filename) {
+ dump_stack_reset(sc);
+ sc->envir = sc->global_env;
+ sc->file_i=0;
+ sc->load_stack[0].kind=port_input|port_string;
+ sc->load_stack[0].rep.string.start = (char *) buf; /* This func respects const */
+ sc->load_stack[0].rep.string.past_the_end = (char *) buf + len;
+ sc->load_stack[0].rep.string.curr = (char *) buf;
+ port_init_location(sc, &sc->load_stack[0], filename ? mk_string(sc, filename) : NULL);
+ sc->loadport=mk_port(sc,sc->load_stack);
+ sc->retcode=0;
+ sc->interactive_repl=0;
+ sc->inport=sc->loadport;
+ sc->args = mk_integer(sc,sc->file_i);
+ Eval_Cycle(sc, OP_T0LVL);
+ typeflag(sc->loadport)=T_ATOM;
+ if(sc->retcode==0) {
+ sc->retcode=sc->nesting!=0;
+ }
+
+ port_clear_location(sc, &sc->load_stack[0]);
+}
+
+void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
+ pointer x;
+ pointer *sslot;
+ x = find_slot_spec_in_env(sc, envir, symbol, 0, &sslot);
+ if (x != sc->NIL) {
+ set_slot_in_env(sc, x, value);
+ } else {
+ new_slot_spec_in_env(sc, symbol, value, sslot);
+ }
+}
+
+#if !STANDALONE
+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
+{
+ scheme_define(sc,
+ sc->global_env,
+ mk_symbol(sc,sr->name),
+ mk_foreign_func(sc, sr->f));
+}
+
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int count)
+{
+ int i;
+ for(i = 0; i < count; i++)
+ {
+ scheme_register_foreign_func(sc, list + i);
+ }
+}
+
+pointer scheme_apply0(scheme *sc, const char *procname)
+{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
+
+void save_from_C_call(scheme *sc)
+{
+ pointer saved_data =
+ cons(sc,
+ car(sc->sink),
+ cons(sc,
+ sc->envir,
+ sc->dump));
+ /* Push */
+ sc->c_nest = cons(sc, saved_data, sc->c_nest);
+ /* Truncate the dump stack so TS will return here when done, not
+ directly resume pre-C-call operations. */
+ dump_stack_reset(sc);
+}
+void restore_from_C_call(scheme *sc)
+{
+ car(sc->sink) = caar(sc->c_nest);
+ sc->envir = cadar(sc->c_nest);
+ sc->dump = cdr(cdar(sc->c_nest));
+ /* Pop */
+ sc->c_nest = cdr(sc->c_nest);
+}
+
+/* "func" and "args" are assumed to be already eval'ed. */
+pointer scheme_call(scheme *sc, pointer func, pointer args)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->envir = sc->global_env;
+ sc->args = args;
+ sc->code = func;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_APPLY);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+pointer scheme_eval(scheme *sc, pointer obj)
+{
+ int old_repl = sc->interactive_repl;
+ sc->interactive_repl = 0;
+ save_from_C_call(sc);
+ sc->args = sc->NIL;
+ sc->code = obj;
+ sc->retcode = 0;
+ Eval_Cycle(sc, OP_EVAL);
+ sc->interactive_repl = old_repl;
+ restore_from_C_call(sc);
+ return sc->value;
+}
+
+
+#endif
+
+/* ========== Main ========== */
+
+#if STANDALONE
+
+#if defined(__APPLE__) && !defined (OSX)
+int main()
+{
+ extern MacTS_main(int argc, char **argv);
+ char** argv;
+ int argc = ccommand(&argv);
+ MacTS_main(argc,argv);
+ return 0;
+}
+int MacTS_main(int argc, char **argv) {
+#else
+int main(int argc, char **argv) {
+#endif
+ scheme sc;
+ FILE *fin;
+ char *file_name=InitFile;
+ int retcode;
+ int isfile=1;
+
+ if(argc==1) {
+ printf(banner);
+ }
+ if(argc==2 && strcmp(argv[1],"-?")==0) {
+ printf("Usage: tinyscheme -?\n");
+ printf("or: tinyscheme [<file1> <file2> ...]\n");
+ printf("followed by\n");
+ printf(" -1 <file> [<arg1> <arg2> ...]\n");
+ printf(" -c <Scheme commands> [<arg1> <arg2> ...]\n");
+ printf("assuming that the executable is named tinyscheme.\n");
+ printf("Use - as filename for stdin.\n");
+ return 1;
+ }
+ if(!scheme_init(&sc)) {
+ fprintf(stderr,"Could not initialize!\n");
+ return 2;
+ }
+ scheme_set_input_port_file(&sc, stdin);
+ scheme_set_output_port_file(&sc, stdout);
+#if USE_DL
+ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
+#endif
+ argv++;
+ if(access(file_name,0)!=0) {
+ char *p=getenv("TINYSCHEMEINIT");
+ if(p!=0) {
+ file_name=p;
+ }
+ }
+ do {
+ if(strcmp(file_name,"-")==0) {
+ fin=stdin;
+ } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
+ pointer args=sc.NIL;
+ isfile=file_name[1]=='1';
+ file_name=*argv++;
+ if(strcmp(file_name,"-")==0) {
+ fin=stdin;
+ } else if(isfile) {
+ fin=fopen(file_name,"r");
+ }
+ for(;*argv;argv++) {
+ pointer value=mk_string(&sc,*argv);
+ args=cons(&sc,value,args);
+ }
+ args=reverse_in_place(&sc,sc.NIL,args);
+ scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
+
+ } else {
+ fin=fopen(file_name,"r");
+ }
+ if(isfile && fin==0) {
+ fprintf(stderr,"Could not open file %s\n",file_name);
+ } else {
+ if(isfile) {
+ scheme_load_named_file(&sc,fin,file_name);
+ } else {
+ scheme_load_string(&sc,file_name);
+ }
+ if(!isfile || fin!=stdin) {
+ if(sc.retcode!=0) {
+ fprintf(stderr,"Errors encountered reading %s\n",file_name);
+ }
+ if(isfile) {
+ fclose(fin);
+ }
+ }
+ }
+ file_name=*argv++;
+ } while(file_name!=0);
+ if(argc==1) {
+ scheme_load_named_file(&sc,stdin,0);
+ }
+ retcode=sc.retcode;
+ scheme_deinit(&sc);
+
+ return retcode;
+}
+
+#endif
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/tests/gpgscm/scheme.h b/tests/gpgscm/scheme.h
new file mode 100644
index 0000000..6f917da
--- /dev/null
+++ b/tests/gpgscm/scheme.h
@@ -0,0 +1,290 @@
+/* SCHEME.H */
+
+#ifndef _SCHEME_H
+#define _SCHEME_H
+
+#include <stdio.h>
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/*
+ * Default values for #define'd symbols
+ */
+#ifndef STANDALONE /* If used as standalone interpreter */
+# define STANDALONE 1
+#endif
+
+#ifndef _MSC_VER
+# define USE_STRCASECMP 1
+# ifndef USE_STRLWR
+# define USE_STRLWR 1
+# endif
+# define SCHEME_EXPORT
+#else
+# define USE_STRCASECMP 0
+# define USE_STRLWR 0
+# ifdef _SCHEME_SOURCE
+# define SCHEME_EXPORT __declspec(dllexport)
+# else
+# define SCHEME_EXPORT __declspec(dllimport)
+# endif
+#endif
+
+#if USE_NO_FEATURES
+# define USE_MATH 0
+# define USE_CHAR_CLASSIFIERS 0
+# define USE_ASCII_NAMES 0
+# define USE_STRING_PORTS 0
+# define USE_ERROR_HOOK 0
+# define USE_TRACING 0
+# define USE_COLON_HOOK 0
+# define USE_COMPILE_HOOK 0
+# define USE_DL 0
+# define USE_PLIST 0
+# define USE_SMALL_INTEGERS 0
+# define USE_HISTORY 0
+#endif
+
+
+#if USE_DL
+# define USE_INTERFACE 1
+#endif
+
+
+#ifndef USE_MATH /* If math support is needed */
+# define USE_MATH 1
+#endif
+
+#ifndef USE_CHAR_CLASSIFIERS /* If char classifiers are needed */
+# define USE_CHAR_CLASSIFIERS 1
+#endif
+
+#ifndef USE_ASCII_NAMES /* If extended escaped characters are needed */
+# define USE_ASCII_NAMES 1
+#endif
+
+#ifndef USE_STRING_PORTS /* Enable string ports */
+# define USE_STRING_PORTS 1
+#endif
+
+#ifndef USE_TRACING
+# define USE_TRACING 1
+#endif
+
+#ifndef USE_PLIST
+# define USE_PLIST 0
+#endif
+
+/* Keep a history of function calls. This enables a feature similar
+ * to stack traces. */
+#ifndef USE_HISTORY
+# define USE_HISTORY 1
+#endif
+
+/* To force system errors through user-defined error handling (see *error-hook*) */
+#ifndef USE_ERROR_HOOK
+# define USE_ERROR_HOOK 1
+#endif
+
+#ifndef USE_COLON_HOOK /* Enable qualified qualifier */
+# define USE_COLON_HOOK 1
+#endif
+
+/* Compile functions using *compile-hook*. The default hook expands
+ * macros. */
+#ifndef USE_COMPILE_HOOK
+# define USE_COMPILE_HOOK 1
+#endif
+
+/* Enable faster opcode dispatch. */
+#ifndef USE_THREADED_CODE
+# define USE_THREADED_CODE 1
+#endif
+
+/* Use a static set of cells to represent small numbers. This set
+ * notably includes all opcodes, and hence saves a cell reservation
+ * during 's_save'. */
+#ifndef USE_SMALL_INTEGERS
+# define USE_SMALL_INTEGERS 1
+#endif
+
+#ifndef USE_STRCASECMP /* stricmp for Unix */
+# define USE_STRCASECMP 0
+#endif
+
+#ifndef USE_STRLWR
+# define USE_STRLWR 1
+#endif
+
+#ifndef STDIO_ADDS_CR /* Define if DOS/Windows */
+# define STDIO_ADDS_CR 0
+#endif
+
+#ifndef INLINE
+# define INLINE
+#endif
+
+#ifndef USE_INTERFACE
+# define USE_INTERFACE 0
+#endif
+
+#ifndef SHOW_ERROR_LINE /* Show error line in file */
+# define SHOW_ERROR_LINE 1
+#endif
+
+typedef struct scheme scheme;
+typedef struct cell *pointer;
+
+typedef void * (*func_alloc)(size_t);
+typedef void (*func_dealloc)(void *);
+
+/* table of functions required for foreign objects */
+typedef struct foreign_object_vtable {
+ void (*finalize)(scheme *sc, void *data);
+ void (*to_string)(scheme *sc, char *out, size_t size, void *data);
+} foreign_object_vtable;
+
+/* num, for generic arithmetic */
+typedef struct num {
+ char is_fixnum;
+ union {
+ long ivalue;
+ double rvalue;
+ } value;
+} num;
+
+SCHEME_EXPORT scheme *scheme_init_new(void);
+SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
+SCHEME_EXPORT int scheme_init(scheme *sc);
+SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
+SCHEME_EXPORT void scheme_deinit(scheme *sc);
+void scheme_set_input_port_file(scheme *sc, FILE *fin);
+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin);
+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end);
+SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin);
+SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename);
+SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd);
+SCHEME_EXPORT void scheme_load_memory(scheme *sc, const char *buf, size_t len,
+ const char *filename);
+SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname);
+SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args);
+SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj);
+void scheme_set_external_data(scheme *sc, void *p);
+SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value);
+
+typedef pointer (*foreign_func)(scheme *, pointer);
+
+pointer _cons(scheme *sc, pointer a, pointer b, int immutable);
+pointer mk_integer(scheme *sc, long num);
+pointer mk_real(scheme *sc, double num);
+pointer mk_symbol(scheme *sc, const char *name);
+pointer gensym(scheme *sc);
+pointer mk_string(scheme *sc, const char *str);
+pointer mk_counted_string(scheme *sc, const char *str, int len);
+pointer mk_empty_string(scheme *sc, int len, char fill);
+pointer mk_character(scheme *sc, int c);
+pointer mk_foreign_func(scheme *sc, foreign_func f);
+pointer mk_foreign_object(scheme *sc, const foreign_object_vtable *vtable, void *data);
+void putstr(scheme *sc, const char *s);
+int list_length(scheme *sc, pointer a);
+int eqv(pointer a, pointer b);
+
+
+#if USE_INTERFACE
+struct scheme_interface {
+ void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value);
+ pointer (*cons)(scheme *sc, pointer a, pointer b);
+ pointer (*immutable_cons)(scheme *sc, pointer a, pointer b);
+ pointer (*reserve_cells)(scheme *sc, int n);
+ pointer (*mk_integer)(scheme *sc, long num);
+ pointer (*mk_real)(scheme *sc, double num);
+ pointer (*mk_symbol)(scheme *sc, const char *name);
+ pointer (*gensym)(scheme *sc);
+ pointer (*mk_string)(scheme *sc, const char *str);
+ pointer (*mk_counted_string)(scheme *sc, const char *str, int len);
+ pointer (*mk_character)(scheme *sc, int c);
+ pointer (*mk_vector)(scheme *sc, int len);
+ pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
+ pointer (*mk_foreign_object)(scheme *sc, const foreign_object_vtable *vtable, void *data);
+ const foreign_object_vtable *(*get_foreign_object_vtable)(pointer p);
+ void *(*get_foreign_object_data)(pointer p);
+ void (*putstr)(scheme *sc, const char *s);
+ void (*putcharacter)(scheme *sc, int c);
+
+ int (*is_string)(pointer p);
+ char *(*string_value)(pointer p);
+ int (*is_number)(pointer p);
+ num (*nvalue)(pointer p);
+ long (*ivalue)(pointer p);
+ double (*rvalue)(pointer p);
+ int (*is_integer)(pointer p);
+ int (*is_real)(pointer p);
+ int (*is_character)(pointer p);
+ long (*charvalue)(pointer p);
+ int (*is_list)(scheme *sc, pointer p);
+ int (*is_vector)(pointer p);
+ int (*list_length)(scheme *sc, pointer vec);
+ long (*vector_length)(pointer vec);
+ void (*fill_vector)(pointer vec, pointer elem);
+ pointer (*vector_elem)(pointer vec, int ielem);
+ pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel);
+ int (*is_port)(pointer p);
+
+ int (*is_pair)(pointer p);
+ pointer (*pair_car)(pointer p);
+ pointer (*pair_cdr)(pointer p);
+ pointer (*set_car)(pointer p, pointer q);
+ pointer (*set_cdr)(pointer p, pointer q);
+
+ int (*is_symbol)(pointer p);
+ char *(*symname)(pointer p);
+
+ int (*is_syntax)(pointer p);
+ int (*is_proc)(pointer p);
+ int (*is_foreign)(pointer p);
+ char *(*syntaxname)(pointer p);
+ int (*is_closure)(pointer p);
+ int (*is_macro)(pointer p);
+ pointer (*closure_code)(pointer p);
+ pointer (*closure_env)(pointer p);
+
+ int (*is_continuation)(pointer p);
+ int (*is_promise)(pointer p);
+ int (*is_environment)(pointer p);
+ int (*is_immutable)(pointer p);
+ void (*setimmutable)(pointer p);
+ void (*load_file)(scheme *sc, FILE *fin);
+ void (*load_string)(scheme *sc, const char *input);
+ pointer (*mk_port_from_file)(scheme *sc, FILE *f, int kind);
+};
+#endif
+
+#if !STANDALONE
+typedef struct scheme_registerable
+{
+ foreign_func f;
+ const char * name;
+}
+scheme_registerable;
+
+void scheme_register_foreign_func_list(scheme * sc,
+ scheme_registerable * list,
+ int n);
+
+#endif /* !STANDALONE */
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
+
+
+/*
+Local variables:
+c-file-style: "k&r"
+End:
+*/
diff --git a/tests/gpgscm/small-integers.h b/tests/gpgscm/small-integers.h
new file mode 100644
index 0000000..46eda34
--- /dev/null
+++ b/tests/gpgscm/small-integers.h
@@ -0,0 +1,847 @@
+/* Constant integer objects for TinySCHEME.
+ *
+ * Copyright (C) 2017 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+/*
+ * Ohne Worte. Generated using:
+ *
+ * $ n=0; while read line ; do \
+ * echo "DEFINE_INTEGER($n)" ; \
+ * n="$(expr $n + 1)" ; \
+ * done <./init.scm >> small-integers.h
+ */
+
+DEFINE_INTEGER(0)
+DEFINE_INTEGER(1)
+DEFINE_INTEGER(2)
+DEFINE_INTEGER(3)
+DEFINE_INTEGER(4)
+DEFINE_INTEGER(5)
+DEFINE_INTEGER(6)
+DEFINE_INTEGER(7)
+DEFINE_INTEGER(8)
+DEFINE_INTEGER(9)
+DEFINE_INTEGER(10)
+DEFINE_INTEGER(11)
+DEFINE_INTEGER(12)
+DEFINE_INTEGER(13)
+DEFINE_INTEGER(14)
+DEFINE_INTEGER(15)
+DEFINE_INTEGER(16)
+DEFINE_INTEGER(17)
+DEFINE_INTEGER(18)
+DEFINE_INTEGER(19)
+DEFINE_INTEGER(20)
+DEFINE_INTEGER(21)
+DEFINE_INTEGER(22)
+DEFINE_INTEGER(23)
+DEFINE_INTEGER(24)
+DEFINE_INTEGER(25)
+DEFINE_INTEGER(26)
+DEFINE_INTEGER(27)
+DEFINE_INTEGER(28)
+DEFINE_INTEGER(29)
+DEFINE_INTEGER(30)
+DEFINE_INTEGER(31)
+DEFINE_INTEGER(32)
+DEFINE_INTEGER(33)
+DEFINE_INTEGER(34)
+DEFINE_INTEGER(35)
+DEFINE_INTEGER(36)
+DEFINE_INTEGER(37)
+DEFINE_INTEGER(38)
+DEFINE_INTEGER(39)
+DEFINE_INTEGER(40)
+DEFINE_INTEGER(41)
+DEFINE_INTEGER(42)
+DEFINE_INTEGER(43)
+DEFINE_INTEGER(44)
+DEFINE_INTEGER(45)
+DEFINE_INTEGER(46)
+DEFINE_INTEGER(47)
+DEFINE_INTEGER(48)
+DEFINE_INTEGER(49)
+DEFINE_INTEGER(50)
+DEFINE_INTEGER(51)
+DEFINE_INTEGER(52)
+DEFINE_INTEGER(53)
+DEFINE_INTEGER(54)
+DEFINE_INTEGER(55)
+DEFINE_INTEGER(56)
+DEFINE_INTEGER(57)
+DEFINE_INTEGER(58)
+DEFINE_INTEGER(59)
+DEFINE_INTEGER(60)
+DEFINE_INTEGER(61)
+DEFINE_INTEGER(62)
+DEFINE_INTEGER(63)
+DEFINE_INTEGER(64)
+DEFINE_INTEGER(65)
+DEFINE_INTEGER(66)
+DEFINE_INTEGER(67)
+DEFINE_INTEGER(68)
+DEFINE_INTEGER(69)
+DEFINE_INTEGER(70)
+DEFINE_INTEGER(71)
+DEFINE_INTEGER(72)
+DEFINE_INTEGER(73)
+DEFINE_INTEGER(74)
+DEFINE_INTEGER(75)
+DEFINE_INTEGER(76)
+DEFINE_INTEGER(77)
+DEFINE_INTEGER(78)
+DEFINE_INTEGER(79)
+DEFINE_INTEGER(80)
+DEFINE_INTEGER(81)
+DEFINE_INTEGER(82)
+DEFINE_INTEGER(83)
+DEFINE_INTEGER(84)
+DEFINE_INTEGER(85)
+DEFINE_INTEGER(86)
+DEFINE_INTEGER(87)
+DEFINE_INTEGER(88)
+DEFINE_INTEGER(89)
+DEFINE_INTEGER(90)
+DEFINE_INTEGER(91)
+DEFINE_INTEGER(92)
+DEFINE_INTEGER(93)
+DEFINE_INTEGER(94)
+DEFINE_INTEGER(95)
+DEFINE_INTEGER(96)
+DEFINE_INTEGER(97)
+DEFINE_INTEGER(98)
+DEFINE_INTEGER(99)
+DEFINE_INTEGER(100)
+DEFINE_INTEGER(101)
+DEFINE_INTEGER(102)
+DEFINE_INTEGER(103)
+DEFINE_INTEGER(104)
+DEFINE_INTEGER(105)
+DEFINE_INTEGER(106)
+DEFINE_INTEGER(107)
+DEFINE_INTEGER(108)
+DEFINE_INTEGER(109)
+DEFINE_INTEGER(110)
+DEFINE_INTEGER(111)
+DEFINE_INTEGER(112)
+DEFINE_INTEGER(113)
+DEFINE_INTEGER(114)
+DEFINE_INTEGER(115)
+DEFINE_INTEGER(116)
+DEFINE_INTEGER(117)
+DEFINE_INTEGER(118)
+DEFINE_INTEGER(119)
+DEFINE_INTEGER(120)
+DEFINE_INTEGER(121)
+DEFINE_INTEGER(122)
+DEFINE_INTEGER(123)
+DEFINE_INTEGER(124)
+DEFINE_INTEGER(125)
+DEFINE_INTEGER(126)
+DEFINE_INTEGER(127)
+DEFINE_INTEGER(128)
+DEFINE_INTEGER(129)
+DEFINE_INTEGER(130)
+DEFINE_INTEGER(131)
+DEFINE_INTEGER(132)
+DEFINE_INTEGER(133)
+DEFINE_INTEGER(134)
+DEFINE_INTEGER(135)
+DEFINE_INTEGER(136)
+DEFINE_INTEGER(137)
+DEFINE_INTEGER(138)
+DEFINE_INTEGER(139)
+DEFINE_INTEGER(140)
+DEFINE_INTEGER(141)
+DEFINE_INTEGER(142)
+DEFINE_INTEGER(143)
+DEFINE_INTEGER(144)
+DEFINE_INTEGER(145)
+DEFINE_INTEGER(146)
+DEFINE_INTEGER(147)
+DEFINE_INTEGER(148)
+DEFINE_INTEGER(149)
+DEFINE_INTEGER(150)
+DEFINE_INTEGER(151)
+DEFINE_INTEGER(152)
+DEFINE_INTEGER(153)
+DEFINE_INTEGER(154)
+DEFINE_INTEGER(155)
+DEFINE_INTEGER(156)
+DEFINE_INTEGER(157)
+DEFINE_INTEGER(158)
+DEFINE_INTEGER(159)
+DEFINE_INTEGER(160)
+DEFINE_INTEGER(161)
+DEFINE_INTEGER(162)
+DEFINE_INTEGER(163)
+DEFINE_INTEGER(164)
+DEFINE_INTEGER(165)
+DEFINE_INTEGER(166)
+DEFINE_INTEGER(167)
+DEFINE_INTEGER(168)
+DEFINE_INTEGER(169)
+DEFINE_INTEGER(170)
+DEFINE_INTEGER(171)
+DEFINE_INTEGER(172)
+DEFINE_INTEGER(173)
+DEFINE_INTEGER(174)
+DEFINE_INTEGER(175)
+DEFINE_INTEGER(176)
+DEFINE_INTEGER(177)
+DEFINE_INTEGER(178)
+DEFINE_INTEGER(179)
+DEFINE_INTEGER(180)
+DEFINE_INTEGER(181)
+DEFINE_INTEGER(182)
+DEFINE_INTEGER(183)
+DEFINE_INTEGER(184)
+DEFINE_INTEGER(185)
+DEFINE_INTEGER(186)
+DEFINE_INTEGER(187)
+DEFINE_INTEGER(188)
+DEFINE_INTEGER(189)
+DEFINE_INTEGER(190)
+DEFINE_INTEGER(191)
+DEFINE_INTEGER(192)
+DEFINE_INTEGER(193)
+DEFINE_INTEGER(194)
+DEFINE_INTEGER(195)
+DEFINE_INTEGER(196)
+DEFINE_INTEGER(197)
+DEFINE_INTEGER(198)
+DEFINE_INTEGER(199)
+DEFINE_INTEGER(200)
+DEFINE_INTEGER(201)
+DEFINE_INTEGER(202)
+DEFINE_INTEGER(203)
+DEFINE_INTEGER(204)
+DEFINE_INTEGER(205)
+DEFINE_INTEGER(206)
+DEFINE_INTEGER(207)
+DEFINE_INTEGER(208)
+DEFINE_INTEGER(209)
+DEFINE_INTEGER(210)
+DEFINE_INTEGER(211)
+DEFINE_INTEGER(212)
+DEFINE_INTEGER(213)
+DEFINE_INTEGER(214)
+DEFINE_INTEGER(215)
+DEFINE_INTEGER(216)
+DEFINE_INTEGER(217)
+DEFINE_INTEGER(218)
+DEFINE_INTEGER(219)
+DEFINE_INTEGER(220)
+DEFINE_INTEGER(221)
+DEFINE_INTEGER(222)
+DEFINE_INTEGER(223)
+DEFINE_INTEGER(224)
+DEFINE_INTEGER(225)
+DEFINE_INTEGER(226)
+DEFINE_INTEGER(227)
+DEFINE_INTEGER(228)
+DEFINE_INTEGER(229)
+DEFINE_INTEGER(230)
+DEFINE_INTEGER(231)
+DEFINE_INTEGER(232)
+DEFINE_INTEGER(233)
+DEFINE_INTEGER(234)
+DEFINE_INTEGER(235)
+DEFINE_INTEGER(236)
+DEFINE_INTEGER(237)
+DEFINE_INTEGER(238)
+DEFINE_INTEGER(239)
+DEFINE_INTEGER(240)
+DEFINE_INTEGER(241)
+DEFINE_INTEGER(242)
+DEFINE_INTEGER(243)
+DEFINE_INTEGER(244)
+DEFINE_INTEGER(245)
+DEFINE_INTEGER(246)
+DEFINE_INTEGER(247)
+DEFINE_INTEGER(248)
+DEFINE_INTEGER(249)
+DEFINE_INTEGER(250)
+DEFINE_INTEGER(251)
+DEFINE_INTEGER(252)
+DEFINE_INTEGER(253)
+DEFINE_INTEGER(254)
+DEFINE_INTEGER(255)
+DEFINE_INTEGER(256)
+DEFINE_INTEGER(257)
+DEFINE_INTEGER(258)
+DEFINE_INTEGER(259)
+DEFINE_INTEGER(260)
+DEFINE_INTEGER(261)
+DEFINE_INTEGER(262)
+DEFINE_INTEGER(263)
+DEFINE_INTEGER(264)
+DEFINE_INTEGER(265)
+DEFINE_INTEGER(266)
+DEFINE_INTEGER(267)
+DEFINE_INTEGER(268)
+DEFINE_INTEGER(269)
+DEFINE_INTEGER(270)
+DEFINE_INTEGER(271)
+DEFINE_INTEGER(272)
+DEFINE_INTEGER(273)
+DEFINE_INTEGER(274)
+DEFINE_INTEGER(275)
+DEFINE_INTEGER(276)
+DEFINE_INTEGER(277)
+DEFINE_INTEGER(278)
+DEFINE_INTEGER(279)
+DEFINE_INTEGER(280)
+DEFINE_INTEGER(281)
+DEFINE_INTEGER(282)
+DEFINE_INTEGER(283)
+DEFINE_INTEGER(284)
+DEFINE_INTEGER(285)
+DEFINE_INTEGER(286)
+DEFINE_INTEGER(287)
+DEFINE_INTEGER(288)
+DEFINE_INTEGER(289)
+DEFINE_INTEGER(290)
+DEFINE_INTEGER(291)
+DEFINE_INTEGER(292)
+DEFINE_INTEGER(293)
+DEFINE_INTEGER(294)
+DEFINE_INTEGER(295)
+DEFINE_INTEGER(296)
+DEFINE_INTEGER(297)
+DEFINE_INTEGER(298)
+DEFINE_INTEGER(299)
+DEFINE_INTEGER(300)
+DEFINE_INTEGER(301)
+DEFINE_INTEGER(302)
+DEFINE_INTEGER(303)
+DEFINE_INTEGER(304)
+DEFINE_INTEGER(305)
+DEFINE_INTEGER(306)
+DEFINE_INTEGER(307)
+DEFINE_INTEGER(308)
+DEFINE_INTEGER(309)
+DEFINE_INTEGER(310)
+DEFINE_INTEGER(311)
+DEFINE_INTEGER(312)
+DEFINE_INTEGER(313)
+DEFINE_INTEGER(314)
+DEFINE_INTEGER(315)
+DEFINE_INTEGER(316)
+DEFINE_INTEGER(317)
+DEFINE_INTEGER(318)
+DEFINE_INTEGER(319)
+DEFINE_INTEGER(320)
+DEFINE_INTEGER(321)
+DEFINE_INTEGER(322)
+DEFINE_INTEGER(323)
+DEFINE_INTEGER(324)
+DEFINE_INTEGER(325)
+DEFINE_INTEGER(326)
+DEFINE_INTEGER(327)
+DEFINE_INTEGER(328)
+DEFINE_INTEGER(329)
+DEFINE_INTEGER(330)
+DEFINE_INTEGER(331)
+DEFINE_INTEGER(332)
+DEFINE_INTEGER(333)
+DEFINE_INTEGER(334)
+DEFINE_INTEGER(335)
+DEFINE_INTEGER(336)
+DEFINE_INTEGER(337)
+DEFINE_INTEGER(338)
+DEFINE_INTEGER(339)
+DEFINE_INTEGER(340)
+DEFINE_INTEGER(341)
+DEFINE_INTEGER(342)
+DEFINE_INTEGER(343)
+DEFINE_INTEGER(344)
+DEFINE_INTEGER(345)
+DEFINE_INTEGER(346)
+DEFINE_INTEGER(347)
+DEFINE_INTEGER(348)
+DEFINE_INTEGER(349)
+DEFINE_INTEGER(350)
+DEFINE_INTEGER(351)
+DEFINE_INTEGER(352)
+DEFINE_INTEGER(353)
+DEFINE_INTEGER(354)
+DEFINE_INTEGER(355)
+DEFINE_INTEGER(356)
+DEFINE_INTEGER(357)
+DEFINE_INTEGER(358)
+DEFINE_INTEGER(359)
+DEFINE_INTEGER(360)
+DEFINE_INTEGER(361)
+DEFINE_INTEGER(362)
+DEFINE_INTEGER(363)
+DEFINE_INTEGER(364)
+DEFINE_INTEGER(365)
+DEFINE_INTEGER(366)
+DEFINE_INTEGER(367)
+DEFINE_INTEGER(368)
+DEFINE_INTEGER(369)
+DEFINE_INTEGER(370)
+DEFINE_INTEGER(371)
+DEFINE_INTEGER(372)
+DEFINE_INTEGER(373)
+DEFINE_INTEGER(374)
+DEFINE_INTEGER(375)
+DEFINE_INTEGER(376)
+DEFINE_INTEGER(377)
+DEFINE_INTEGER(378)
+DEFINE_INTEGER(379)
+DEFINE_INTEGER(380)
+DEFINE_INTEGER(381)
+DEFINE_INTEGER(382)
+DEFINE_INTEGER(383)
+DEFINE_INTEGER(384)
+DEFINE_INTEGER(385)
+DEFINE_INTEGER(386)
+DEFINE_INTEGER(387)
+DEFINE_INTEGER(388)
+DEFINE_INTEGER(389)
+DEFINE_INTEGER(390)
+DEFINE_INTEGER(391)
+DEFINE_INTEGER(392)
+DEFINE_INTEGER(393)
+DEFINE_INTEGER(394)
+DEFINE_INTEGER(395)
+DEFINE_INTEGER(396)
+DEFINE_INTEGER(397)
+DEFINE_INTEGER(398)
+DEFINE_INTEGER(399)
+DEFINE_INTEGER(400)
+DEFINE_INTEGER(401)
+DEFINE_INTEGER(402)
+DEFINE_INTEGER(403)
+DEFINE_INTEGER(404)
+DEFINE_INTEGER(405)
+DEFINE_INTEGER(406)
+DEFINE_INTEGER(407)
+DEFINE_INTEGER(408)
+DEFINE_INTEGER(409)
+DEFINE_INTEGER(410)
+DEFINE_INTEGER(411)
+DEFINE_INTEGER(412)
+DEFINE_INTEGER(413)
+DEFINE_INTEGER(414)
+DEFINE_INTEGER(415)
+DEFINE_INTEGER(416)
+DEFINE_INTEGER(417)
+DEFINE_INTEGER(418)
+DEFINE_INTEGER(419)
+DEFINE_INTEGER(420)
+DEFINE_INTEGER(421)
+DEFINE_INTEGER(422)
+DEFINE_INTEGER(423)
+DEFINE_INTEGER(424)
+DEFINE_INTEGER(425)
+DEFINE_INTEGER(426)
+DEFINE_INTEGER(427)
+DEFINE_INTEGER(428)
+DEFINE_INTEGER(429)
+DEFINE_INTEGER(430)
+DEFINE_INTEGER(431)
+DEFINE_INTEGER(432)
+DEFINE_INTEGER(433)
+DEFINE_INTEGER(434)
+DEFINE_INTEGER(435)
+DEFINE_INTEGER(436)
+DEFINE_INTEGER(437)
+DEFINE_INTEGER(438)
+DEFINE_INTEGER(439)
+DEFINE_INTEGER(440)
+DEFINE_INTEGER(441)
+DEFINE_INTEGER(442)
+DEFINE_INTEGER(443)
+DEFINE_INTEGER(444)
+DEFINE_INTEGER(445)
+DEFINE_INTEGER(446)
+DEFINE_INTEGER(447)
+DEFINE_INTEGER(448)
+DEFINE_INTEGER(449)
+DEFINE_INTEGER(450)
+DEFINE_INTEGER(451)
+DEFINE_INTEGER(452)
+DEFINE_INTEGER(453)
+DEFINE_INTEGER(454)
+DEFINE_INTEGER(455)
+DEFINE_INTEGER(456)
+DEFINE_INTEGER(457)
+DEFINE_INTEGER(458)
+DEFINE_INTEGER(459)
+DEFINE_INTEGER(460)
+DEFINE_INTEGER(461)
+DEFINE_INTEGER(462)
+DEFINE_INTEGER(463)
+DEFINE_INTEGER(464)
+DEFINE_INTEGER(465)
+DEFINE_INTEGER(466)
+DEFINE_INTEGER(467)
+DEFINE_INTEGER(468)
+DEFINE_INTEGER(469)
+DEFINE_INTEGER(470)
+DEFINE_INTEGER(471)
+DEFINE_INTEGER(472)
+DEFINE_INTEGER(473)
+DEFINE_INTEGER(474)
+DEFINE_INTEGER(475)
+DEFINE_INTEGER(476)
+DEFINE_INTEGER(477)
+DEFINE_INTEGER(478)
+DEFINE_INTEGER(479)
+DEFINE_INTEGER(480)
+DEFINE_INTEGER(481)
+DEFINE_INTEGER(482)
+DEFINE_INTEGER(483)
+DEFINE_INTEGER(484)
+DEFINE_INTEGER(485)
+DEFINE_INTEGER(486)
+DEFINE_INTEGER(487)
+DEFINE_INTEGER(488)
+DEFINE_INTEGER(489)
+DEFINE_INTEGER(490)
+DEFINE_INTEGER(491)
+DEFINE_INTEGER(492)
+DEFINE_INTEGER(493)
+DEFINE_INTEGER(494)
+DEFINE_INTEGER(495)
+DEFINE_INTEGER(496)
+DEFINE_INTEGER(497)
+DEFINE_INTEGER(498)
+DEFINE_INTEGER(499)
+DEFINE_INTEGER(500)
+DEFINE_INTEGER(501)
+DEFINE_INTEGER(502)
+DEFINE_INTEGER(503)
+DEFINE_INTEGER(504)
+DEFINE_INTEGER(505)
+DEFINE_INTEGER(506)
+DEFINE_INTEGER(507)
+DEFINE_INTEGER(508)
+DEFINE_INTEGER(509)
+DEFINE_INTEGER(510)
+DEFINE_INTEGER(511)
+DEFINE_INTEGER(512)
+DEFINE_INTEGER(513)
+DEFINE_INTEGER(514)
+DEFINE_INTEGER(515)
+DEFINE_INTEGER(516)
+DEFINE_INTEGER(517)
+DEFINE_INTEGER(518)
+DEFINE_INTEGER(519)
+DEFINE_INTEGER(520)
+DEFINE_INTEGER(521)
+DEFINE_INTEGER(522)
+DEFINE_INTEGER(523)
+DEFINE_INTEGER(524)
+DEFINE_INTEGER(525)
+DEFINE_INTEGER(526)
+DEFINE_INTEGER(527)
+DEFINE_INTEGER(528)
+DEFINE_INTEGER(529)
+DEFINE_INTEGER(530)
+DEFINE_INTEGER(531)
+DEFINE_INTEGER(532)
+DEFINE_INTEGER(533)
+DEFINE_INTEGER(534)
+DEFINE_INTEGER(535)
+DEFINE_INTEGER(536)
+DEFINE_INTEGER(537)
+DEFINE_INTEGER(538)
+DEFINE_INTEGER(539)
+DEFINE_INTEGER(540)
+DEFINE_INTEGER(541)
+DEFINE_INTEGER(542)
+DEFINE_INTEGER(543)
+DEFINE_INTEGER(544)
+DEFINE_INTEGER(545)
+DEFINE_INTEGER(546)
+DEFINE_INTEGER(547)
+DEFINE_INTEGER(548)
+DEFINE_INTEGER(549)
+DEFINE_INTEGER(550)
+DEFINE_INTEGER(551)
+DEFINE_INTEGER(552)
+DEFINE_INTEGER(553)
+DEFINE_INTEGER(554)
+DEFINE_INTEGER(555)
+DEFINE_INTEGER(556)
+DEFINE_INTEGER(557)
+DEFINE_INTEGER(558)
+DEFINE_INTEGER(559)
+DEFINE_INTEGER(560)
+DEFINE_INTEGER(561)
+DEFINE_INTEGER(562)
+DEFINE_INTEGER(563)
+DEFINE_INTEGER(564)
+DEFINE_INTEGER(565)
+DEFINE_INTEGER(566)
+DEFINE_INTEGER(567)
+DEFINE_INTEGER(568)
+DEFINE_INTEGER(569)
+DEFINE_INTEGER(570)
+DEFINE_INTEGER(571)
+DEFINE_INTEGER(572)
+DEFINE_INTEGER(573)
+DEFINE_INTEGER(574)
+DEFINE_INTEGER(575)
+DEFINE_INTEGER(576)
+DEFINE_INTEGER(577)
+DEFINE_INTEGER(578)
+DEFINE_INTEGER(579)
+DEFINE_INTEGER(580)
+DEFINE_INTEGER(581)
+DEFINE_INTEGER(582)
+DEFINE_INTEGER(583)
+DEFINE_INTEGER(584)
+DEFINE_INTEGER(585)
+DEFINE_INTEGER(586)
+DEFINE_INTEGER(587)
+DEFINE_INTEGER(588)
+DEFINE_INTEGER(589)
+DEFINE_INTEGER(590)
+DEFINE_INTEGER(591)
+DEFINE_INTEGER(592)
+DEFINE_INTEGER(593)
+DEFINE_INTEGER(594)
+DEFINE_INTEGER(595)
+DEFINE_INTEGER(596)
+DEFINE_INTEGER(597)
+DEFINE_INTEGER(598)
+DEFINE_INTEGER(599)
+DEFINE_INTEGER(600)
+DEFINE_INTEGER(601)
+DEFINE_INTEGER(602)
+DEFINE_INTEGER(603)
+DEFINE_INTEGER(604)
+DEFINE_INTEGER(605)
+DEFINE_INTEGER(606)
+DEFINE_INTEGER(607)
+DEFINE_INTEGER(608)
+DEFINE_INTEGER(609)
+DEFINE_INTEGER(610)
+DEFINE_INTEGER(611)
+DEFINE_INTEGER(612)
+DEFINE_INTEGER(613)
+DEFINE_INTEGER(614)
+DEFINE_INTEGER(615)
+DEFINE_INTEGER(616)
+DEFINE_INTEGER(617)
+DEFINE_INTEGER(618)
+DEFINE_INTEGER(619)
+DEFINE_INTEGER(620)
+DEFINE_INTEGER(621)
+DEFINE_INTEGER(622)
+DEFINE_INTEGER(623)
+DEFINE_INTEGER(624)
+DEFINE_INTEGER(625)
+DEFINE_INTEGER(626)
+DEFINE_INTEGER(627)
+DEFINE_INTEGER(628)
+DEFINE_INTEGER(629)
+DEFINE_INTEGER(630)
+DEFINE_INTEGER(631)
+DEFINE_INTEGER(632)
+DEFINE_INTEGER(633)
+DEFINE_INTEGER(634)
+DEFINE_INTEGER(635)
+DEFINE_INTEGER(636)
+DEFINE_INTEGER(637)
+DEFINE_INTEGER(638)
+DEFINE_INTEGER(639)
+DEFINE_INTEGER(640)
+DEFINE_INTEGER(641)
+DEFINE_INTEGER(642)
+DEFINE_INTEGER(643)
+DEFINE_INTEGER(644)
+DEFINE_INTEGER(645)
+DEFINE_INTEGER(646)
+DEFINE_INTEGER(647)
+DEFINE_INTEGER(648)
+DEFINE_INTEGER(649)
+DEFINE_INTEGER(650)
+DEFINE_INTEGER(651)
+DEFINE_INTEGER(652)
+DEFINE_INTEGER(653)
+DEFINE_INTEGER(654)
+DEFINE_INTEGER(655)
+DEFINE_INTEGER(656)
+DEFINE_INTEGER(657)
+DEFINE_INTEGER(658)
+DEFINE_INTEGER(659)
+DEFINE_INTEGER(660)
+DEFINE_INTEGER(661)
+DEFINE_INTEGER(662)
+DEFINE_INTEGER(663)
+DEFINE_INTEGER(664)
+DEFINE_INTEGER(665)
+DEFINE_INTEGER(666)
+DEFINE_INTEGER(667)
+DEFINE_INTEGER(668)
+DEFINE_INTEGER(669)
+DEFINE_INTEGER(670)
+DEFINE_INTEGER(671)
+DEFINE_INTEGER(672)
+DEFINE_INTEGER(673)
+DEFINE_INTEGER(674)
+DEFINE_INTEGER(675)
+DEFINE_INTEGER(676)
+DEFINE_INTEGER(677)
+DEFINE_INTEGER(678)
+DEFINE_INTEGER(679)
+DEFINE_INTEGER(680)
+DEFINE_INTEGER(681)
+DEFINE_INTEGER(682)
+DEFINE_INTEGER(683)
+DEFINE_INTEGER(684)
+DEFINE_INTEGER(685)
+DEFINE_INTEGER(686)
+DEFINE_INTEGER(687)
+DEFINE_INTEGER(688)
+DEFINE_INTEGER(689)
+DEFINE_INTEGER(690)
+DEFINE_INTEGER(691)
+DEFINE_INTEGER(692)
+DEFINE_INTEGER(693)
+DEFINE_INTEGER(694)
+DEFINE_INTEGER(695)
+DEFINE_INTEGER(696)
+DEFINE_INTEGER(697)
+DEFINE_INTEGER(698)
+DEFINE_INTEGER(699)
+DEFINE_INTEGER(700)
+DEFINE_INTEGER(701)
+DEFINE_INTEGER(702)
+DEFINE_INTEGER(703)
+DEFINE_INTEGER(704)
+DEFINE_INTEGER(705)
+DEFINE_INTEGER(706)
+DEFINE_INTEGER(707)
+DEFINE_INTEGER(708)
+DEFINE_INTEGER(709)
+DEFINE_INTEGER(710)
+DEFINE_INTEGER(711)
+DEFINE_INTEGER(712)
+DEFINE_INTEGER(713)
+DEFINE_INTEGER(714)
+DEFINE_INTEGER(715)
+DEFINE_INTEGER(716)
+DEFINE_INTEGER(717)
+DEFINE_INTEGER(718)
+DEFINE_INTEGER(719)
+DEFINE_INTEGER(720)
+DEFINE_INTEGER(721)
+DEFINE_INTEGER(722)
+DEFINE_INTEGER(723)
+DEFINE_INTEGER(724)
+DEFINE_INTEGER(725)
+DEFINE_INTEGER(726)
+DEFINE_INTEGER(727)
+DEFINE_INTEGER(728)
+DEFINE_INTEGER(729)
+DEFINE_INTEGER(730)
+DEFINE_INTEGER(731)
+DEFINE_INTEGER(732)
+DEFINE_INTEGER(733)
+DEFINE_INTEGER(734)
+DEFINE_INTEGER(735)
+DEFINE_INTEGER(736)
+DEFINE_INTEGER(737)
+DEFINE_INTEGER(738)
+DEFINE_INTEGER(739)
+DEFINE_INTEGER(740)
+DEFINE_INTEGER(741)
+DEFINE_INTEGER(742)
+DEFINE_INTEGER(743)
+DEFINE_INTEGER(744)
+DEFINE_INTEGER(745)
+DEFINE_INTEGER(746)
+DEFINE_INTEGER(747)
+DEFINE_INTEGER(748)
+DEFINE_INTEGER(749)
+DEFINE_INTEGER(750)
+DEFINE_INTEGER(751)
+DEFINE_INTEGER(752)
+DEFINE_INTEGER(753)
+DEFINE_INTEGER(754)
+DEFINE_INTEGER(755)
+DEFINE_INTEGER(756)
+DEFINE_INTEGER(757)
+DEFINE_INTEGER(758)
+DEFINE_INTEGER(759)
+DEFINE_INTEGER(760)
+DEFINE_INTEGER(761)
+DEFINE_INTEGER(762)
+DEFINE_INTEGER(763)
+DEFINE_INTEGER(764)
+DEFINE_INTEGER(765)
+DEFINE_INTEGER(766)
+DEFINE_INTEGER(767)
+DEFINE_INTEGER(768)
+DEFINE_INTEGER(769)
+DEFINE_INTEGER(770)
+DEFINE_INTEGER(771)
+DEFINE_INTEGER(772)
+DEFINE_INTEGER(773)
+DEFINE_INTEGER(774)
+DEFINE_INTEGER(775)
+DEFINE_INTEGER(776)
+DEFINE_INTEGER(777)
+DEFINE_INTEGER(778)
+DEFINE_INTEGER(779)
+DEFINE_INTEGER(780)
+DEFINE_INTEGER(781)
+DEFINE_INTEGER(782)
+DEFINE_INTEGER(783)
+DEFINE_INTEGER(784)
+DEFINE_INTEGER(785)
+DEFINE_INTEGER(786)
+DEFINE_INTEGER(787)
+DEFINE_INTEGER(788)
+DEFINE_INTEGER(789)
+DEFINE_INTEGER(790)
+DEFINE_INTEGER(791)
+DEFINE_INTEGER(792)
+DEFINE_INTEGER(793)
+DEFINE_INTEGER(794)
+DEFINE_INTEGER(795)
+DEFINE_INTEGER(796)
+DEFINE_INTEGER(797)
+DEFINE_INTEGER(798)
+DEFINE_INTEGER(799)
+DEFINE_INTEGER(800)
+DEFINE_INTEGER(801)
+DEFINE_INTEGER(802)
+DEFINE_INTEGER(803)
+DEFINE_INTEGER(804)
+DEFINE_INTEGER(805)
+DEFINE_INTEGER(806)
+DEFINE_INTEGER(807)
+DEFINE_INTEGER(808)
+DEFINE_INTEGER(809)
+DEFINE_INTEGER(810)
+DEFINE_INTEGER(811)
+DEFINE_INTEGER(812)
+DEFINE_INTEGER(813)
+DEFINE_INTEGER(814)
+DEFINE_INTEGER(815)
+DEFINE_INTEGER(816)
+DEFINE_INTEGER(817)
diff --git a/tests/gpgscm/t-child.c b/tests/gpgscm/t-child.c
new file mode 100644
index 0000000..f4e3a04
--- /dev/null
+++ b/tests/gpgscm/t-child.c
@@ -0,0 +1,74 @@
+/* Sanity check for the process and IPC primitives.
+ *
+ * Copyright (C) 2016 g10 code GmbH
+ *
+ * This file is part of GnuPG.
+ *
+ * GnuPG is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * GnuPG 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 General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, see <https://www.gnu.org/licenses/>.
+ */
+
+#include <errno.h>
+#include <stdio.h>
+#include <string.h>
+
+#ifdef _WIN32
+# include <fcntl.h>
+# include <io.h>
+#endif
+
+int
+main (int argc, char **argv)
+{
+ char buffer[4096];
+ memset (buffer, 'A', sizeof buffer);
+#if _WIN32
+ if (! setmode (fileno (stdin), O_BINARY))
+ return 23;
+ if (! setmode (fileno (stdout), O_BINARY))
+ return 23;
+#endif
+
+ if (argc == 1)
+ return 2;
+ else if (strcmp (argv[1], "return0") == 0)
+ return 0;
+ else if (strcmp (argv[1], "return1") == 0)
+ return 1;
+ else if (strcmp (argv[1], "return77") == 0)
+ return 77;
+ else if (strcmp (argv[1], "hello_stdout") == 0)
+ fprintf (stdout, "hello");
+ else if (strcmp (argv[1], "hello_stderr") == 0)
+ fprintf (stderr, "hello");
+ else if (strcmp (argv[1], "stdout4096") == 0)
+ fwrite (buffer, 1, sizeof buffer, stdout);
+ else if (strcmp (argv[1], "stdout8192") == 0)
+ {
+ fwrite (buffer, 1, sizeof buffer, stdout);
+ fwrite (buffer, 1, sizeof buffer, stdout);
+ }
+ else if (strcmp (argv[1], "cat") == 0)
+ while (! feof (stdin))
+ {
+ size_t bytes_read;
+ bytes_read = fread (buffer, 1, sizeof buffer, stdin);
+ fwrite (buffer, 1, bytes_read, stdout);
+ }
+ else
+ {
+ fprintf (stderr, "unknown command %s\n", argv[1]);
+ return 2;
+ }
+ return 0;
+}
diff --git a/tests/gpgscm/t-child.scm b/tests/gpgscm/t-child.scm
new file mode 100644
index 0000000..fd1dcc3
--- /dev/null
+++ b/tests/gpgscm/t-child.scm
@@ -0,0 +1,118 @@
+;; Tests for the low-level process and IPC primitives.
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+(echo "Testing process and IPC primitives...")
+
+(define (qualify executable)
+ (string-append executable (getenv "EXEEXT")))
+
+(define child (qualify "t-child"))
+
+(assert (= 0 (call `(,(qualify "t-child") "return0"))))
+(assert (= 1 (call `(,(qualify "t-child") "return1"))))
+(assert (= 77 (call `(,(qualify "t-child") "return77"))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return0") "")))
+ (assert (= 0 (:retcode r)))
+ (assert (string=? "" (:stdout r)))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return1") "")))
+ (assert (= 1 (:retcode r)))
+ (assert (string=? "" (:stdout r)))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "return77") "")))
+ (assert (= 77 (:retcode r)))
+ (assert (string=? "" (:stdout r)))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "hello_stdout") "")))
+ (assert (= 0 (:retcode r)))
+ (assert (string=? "hello" (:stdout r)))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "hello_stderr") "")))
+ (assert (= 0 (:retcode r)))
+ (assert (string=? "" (:stdout r)))
+ (assert (string=? "hello" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "stdout4096") "")))
+ (assert (= 0 (:retcode r)))
+ (assert (= 4096 (string-length (:stdout r))))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "stdout8192") "")))
+ (assert (= 0 (:retcode r)))
+ (assert (= 8192 (string-length (:stdout r))))
+ (assert (string=? "" (:stderr r))))
+
+(let ((r (call-with-io `(,(qualify "t-child") "cat") "hellohello")))
+ (assert (= 0 (:retcode r)))
+ (assert (string=? "hellohello" (:stdout r)))
+ (assert (string=? "" (:stderr r))))
+
+(define (spawn what)
+ (spawn-process-fd what CLOSED_FD STDOUT_FILENO STDERR_FILENO))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
+ (pid1 (spawn `(,(qualify "t-child") "return0"))))
+ (assert (equal? '(0 0)
+ (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return1")))
+ (pid1 (spawn `(,(qualify "t-child") "return0"))))
+ (assert (equal? '(1 0)
+ (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+
+(let ((pid0 (spawn `(,(qualify "t-child") "return0")))
+ (pid1 (spawn `(,(qualify "t-child") "return77")))
+ (pid2 (spawn `(,(qualify "t-child") "return1"))))
+ (assert (equal? '(0 77 1)
+ (wait-processes '("child0" "child1" "child2")
+ (list pid0 pid1 pid2) #t))))
+
+(let* ((p (pipe))
+ (pid0 (spawn-process-fd
+ `(,(qualify "t-child") "hello_stdout")
+ CLOSED_FD (:write-end p) STDERR_FILENO))
+ (_ (close (:write-end p)))
+ (pid1 (spawn-process-fd
+ `(,(qualify "t-child") "cat")
+ (:read-end p) STDOUT_FILENO STDERR_FILENO)))
+ (close (:read-end p))
+ (assert
+ (equal? '(0 0)
+ (wait-processes '("child0" "child1") (list pid0 pid1) #t))))
+(echo " world.")
+
+(tr:do
+ (tr:pipe-do
+ (pipe:spawn `(,child stdout4096))
+ (pipe:spawn `(,child cat)))
+ (tr:call-with-content (lambda (c)
+ (assert (= 4096 (string-length c))))))
+(tr:do
+ (tr:pipe-do
+ (pipe:spawn `(,child stdout8192))
+ (pipe:spawn `(,child cat)))
+ (tr:call-with-content (lambda (c)
+ (assert (= 8192 (string-length c))))))
+
+(echo "All good.")
diff --git a/tests/gpgscm/tests.scm b/tests/gpgscm/tests.scm
new file mode 100644
index 0000000..5141002
--- /dev/null
+++ b/tests/gpgscm/tests.scm
@@ -0,0 +1,886 @@
+;; Common definitions for writing tests.
+;;
+;; Copyright (C) 2016 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+;; Reporting.
+(define (echo . msg)
+ (for-each (lambda (x) (display x) (display " ")) msg)
+ (newline))
+
+(define (info . msg)
+ (apply echo msg)
+ (flush-stdio))
+
+(define (log . msg)
+ (if (> (*verbose*) 0)
+ (apply info msg)))
+
+(define (fail . msg)
+ (apply info msg)
+ (exit 1))
+
+(define (skip . msg)
+ (apply info msg)
+ (exit 77))
+
+(define (make-counter)
+ (let ((c 0))
+ (lambda ()
+ (let ((r c))
+ (set! c (+ 1 c))
+ r))))
+
+(define *progress-nesting* 0)
+
+(define (call-with-progress msg what)
+ (set! *progress-nesting* (+ 1 *progress-nesting*))
+ (if (= 1 *progress-nesting*)
+ (begin
+ (info msg)
+ (display " > ")
+ (flush-stdio)
+ (what (lambda (item)
+ (display item)
+ (display " ")
+ (flush-stdio)))
+ (info "< "))
+ (begin
+ (what (lambda (item) (display ".") (flush-stdio)))
+ (display " ")
+ (flush-stdio)))
+ (set! *progress-nesting* (- *progress-nesting* 1)))
+
+(define (for-each-p msg proc lst . lsts)
+ (apply for-each-p' `(,msg ,proc ,(lambda (x . xs) x) ,lst ,@lsts)))
+
+(define (for-each-p' msg proc fmt lst . lsts)
+ (call-with-progress
+ msg
+ (lambda (progress)
+ (apply for-each
+ `(,(lambda args
+ (progress (apply fmt args))
+ (apply proc args))
+ ,lst ,@lsts)))))
+
+;; Process management.
+(define CLOSED_FD -1)
+(define (call-with-fds what infd outfd errfd)
+ (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
+(define (call what)
+ (call-with-fds what
+ CLOSED_FD
+ (if (< (*verbose*) 0) STDOUT_FILENO CLOSED_FD)
+ (if (< (*verbose*) 0) STDERR_FILENO CLOSED_FD)))
+
+;; Accessor functions for the results of 'spawn-process'.
+(define :stdin car)
+(define :stdout cadr)
+(define :stderr caddr)
+(define :pid cadddr)
+
+(define (call-with-io what in)
+ (let ((h (spawn-process what 0)))
+ (es-write (:stdin h) in)
+ (es-fclose (:stdin h))
+ (let* ((out (es-read-all (:stdout h)))
+ (err (es-read-all (:stderr h)))
+ (result (wait-process (car what) (:pid h) #t)))
+ (es-fclose (:stdout h))
+ (es-fclose (:stderr h))
+ (if (> (*verbose*) 2)
+ (info "Child" (:pid h) "returned:"
+ `((command ,(stringify what))
+ (status ,result)
+ (stdout ,out)
+ (stderr ,err))))
+ (list result out err))))
+
+;; Accessor function for the results of 'call-with-io'. ':stdout' and
+;; ':stderr' can also be used.
+(define :retcode car)
+
+(define (call-check what)
+ (let ((result (call-with-io what "")))
+ (if (= 0 (:retcode result))
+ (:stdout result)
+ (throw (string-append (stringify what) " failed")
+ (:stderr result)))))
+
+(define (call-popen command input-string)
+ (let ((result (call-with-io command input-string)))
+ (if (= 0 (:retcode result))
+ (:stdout result)
+ (throw (:stderr result)))))
+
+;;
+;; estream helpers.
+;;
+
+(define (es-read-all stream)
+ (let loop
+ ((acc ""))
+ (if (es-feof stream)
+ acc
+ (loop (string-append acc (es-read stream 4096))))))
+
+;;
+;; File management.
+;;
+(define (file-exists? name)
+ (call-with-input-file name (lambda (port) #t)))
+
+(define (file=? a b)
+ (file-equal a b #t))
+
+(define (text-file=? a b)
+ (file-equal a b #f))
+
+(define (file-copy from to)
+ (catch '() (unlink to))
+ (letfd ((source (open from (logior O_RDONLY O_BINARY)))
+ (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
+ (splice source sink)))
+
+(define (text-file-copy from to)
+ (catch '() (unlink to))
+ (letfd ((source (open from O_RDONLY))
+ (sink (open to (logior O_WRONLY O_CREAT) #o600)))
+ (splice source sink)))
+
+(define (path-join . components)
+ (let loop ((acc #f) (rest (filter (lambda (s)
+ (not (string=? "" s))) components)))
+ (if (null? rest)
+ acc
+ (loop (if (string? acc)
+ (string-append acc "/" (car rest))
+ (car rest))
+ (cdr rest)))))
+(assert (string=? (path-join "foo" "bar" "baz") "foo/bar/baz"))
+(assert (string=? (path-join "" "bar" "baz") "bar/baz"))
+
+;; Is PATH an absolute path?
+(define (absolute-path? path)
+ (or (char=? #\/ (string-ref path 0))
+ (and *win32* (char=? #\\ (string-ref path 0)))
+ (and *win32*
+ (char-alphabetic? (string-ref path 0))
+ (char=? #\: (string-ref path 1))
+ (or (char=? #\/ (string-ref path 2))
+ (char=? #\\ (string-ref path 2))))))
+
+;; Make PATH absolute.
+(define (canonical-path path)
+ (if (absolute-path? path) path (path-join (getcwd) path)))
+
+(define (in-srcdir . names)
+ (canonical-path (apply path-join (cons (getenv "abs_top_srcdir") names))))
+
+;; Split a list of paths.
+(define (pathsep-split s)
+ (string-split s *pathsep*))
+
+;; Join a list of paths.
+(define (pathsep-join paths)
+ (foldr (lambda (a b) (string-append a (string *pathsep*) b))
+ (car paths)
+ (cdr paths)))
+
+;; Try to find NAME in PATHS. Returns the full path name on success,
+;; or raises an error.
+(define (path-expand name paths)
+ (let loop ((path paths))
+ (if (null? path)
+ (throw "Could not find" name "in" paths)
+ (let* ((qualified-name (path-join (car path) name))
+ (file-exists (call-with-input-file qualified-name
+ (lambda (x) #t))))
+ (if file-exists
+ qualified-name
+ (loop (cdr path)))))))
+
+;; Expand NAME using the gpgscm load path. Use like this:
+;; (load (with-path "library.scm"))
+(define (with-path name)
+ (catch name
+ (path-expand name (pathsep-split (getenv "GPGSCM_PATH")))))
+
+(define (basename path)
+ (let ((i (string-index path #\/)))
+ (if (equal? i #f)
+ path
+ (basename (substring path (+ 1 i) (string-length path))))))
+
+(define (basename-suffix path suffix)
+ (basename
+ (if (string-suffix? path suffix)
+ (substring path 0 (- (string-length path) (string-length suffix)))
+ path)))
+
+(define (dirname path)
+ (let ((i (string-rindex path #\/)))
+ (if i (substring path 0 i) ".")))
+(assert (string=? "foo/bar" (dirname "foo/bar/baz")))
+
+;; Helper for (pipe).
+(define :read-end car)
+(define :write-end cadr)
+
+;; let-like macro that manages file descriptors.
+;;
+;; (letfd <bindings> <body>)
+;;
+;; Bind all variables given in <bindings> and initialize each of them
+;; to the given initial value, and close them after evaluating <body>.
+(define-macro (letfd bindings . body)
+ (let bind ((bindings' bindings))
+ (if (null? bindings')
+ `(begin ,@body)
+ (let* ((binding (car bindings'))
+ (name (car binding))
+ (initializer (cadr binding)))
+ `(let ((,name ,initializer))
+ (finally (close ,name)
+ ,(bind (cdr bindings'))))))))
+
+(define-macro (with-working-directory new-directory . expressions)
+ (let ((new-dir (gensym))
+ (old-dir (gensym)))
+ `(let* ((,new-dir ,new-directory)
+ (,old-dir (getcwd)))
+ (dynamic-wind
+ (lambda () (if ,new-dir (chdir ,new-dir)))
+ (lambda () ,@expressions)
+ (lambda () (chdir ,old-dir))))))
+
+;; Make a temporary directory. If arguments are given, they are
+;; joined using path-join, and must end in a component ending in
+;; "XXXXXX". If no arguments are given, a suitable location and
+;; generic name is used. Returns an absolute path.
+(define (mkdtemp . components)
+ (canonical-path (_mkdtemp (if (null? components)
+ (path-join
+ (get-temp-path)
+ (string-append "gpgscm-" (get-isotime) "-"
+ (basename-suffix *scriptname* ".scm")
+ "-XXXXXX"))
+ (apply path-join components)))))
+
+;; Make a temporary directory and remove it at interpreter shutdown.
+;; Note that there are macros that limit the lifetime of temporary
+;; directories and files to a lexical scope. Use those if possible.
+;; Otherwise this works like mkdtemp.
+(define (mkdtemp-autoremove . components)
+ (let ((dir (apply mkdtemp components)))
+ (atexit (lambda () (unlink-recursively dir)))
+ dir))
+
+(define-macro (with-temporary-working-directory . expressions)
+ (let ((tmp-sym (gensym)))
+ `(let* ((,tmp-sym (mkdtemp)))
+ (finally (unlink-recursively ,tmp-sym)
+ (with-working-directory ,tmp-sym
+ ,@expressions)))))
+
+(define (make-temporary-file . args)
+ (canonical-path (path-join
+ (mkdtemp)
+ (if (null? args) "a" (car args)))))
+
+(define (remove-temporary-file filename)
+ (catch '()
+ (unlink filename))
+ (let ((dirname (substring filename 0 (string-rindex filename #\/))))
+ (catch (echo "removing temporary directory" dirname "failed")
+ (rmdir dirname))))
+
+;; let-like macro that manages temporary files.
+;;
+;; (lettmp <bindings> <body>)
+;;
+;; Bind all variables given in <bindings>, initialize each of them to
+;; a string representing an unique path in the filesystem, and delete
+;; them after evaluating <body>.
+(define-macro (lettmp bindings . body)
+ (let bind ((bindings' bindings))
+ (if (null? bindings')
+ `(begin ,@body)
+ (let ((name (car bindings'))
+ (rest (cdr bindings')))
+ `(let ((,name (make-temporary-file ,(symbol->string name))))
+ (finally (remove-temporary-file ,name)
+ ,(bind rest)))))))
+
+(define (check-execution source transformer)
+ (lettmp (sink)
+ (transformer source sink)))
+
+(define (check-identity source transformer)
+ (lettmp (sink)
+ (transformer source sink)
+ (if (not (file=? source sink))
+ (fail "mismatch"))))
+
+;;
+;; Monadic pipe support.
+;;
+
+(define pipeM
+ (package
+ (define (new procs source sink producer)
+ (package
+ (define (dump)
+ (write (list procs source sink producer))
+ (newline))
+ (define (add-proc command pid)
+ (new (cons (list command pid) procs) source sink producer))
+ (define (commands)
+ (map car procs))
+ (define (pids)
+ (map cadr procs))
+ (define (set-source source')
+ (new procs source' sink producer))
+ (define (set-sink sink')
+ (new procs source sink' producer))
+ (define (set-producer producer')
+ (if producer
+ (throw "producer already set"))
+ (new procs source sink producer'))))))
+
+
+(define (pipe:do . commands)
+ (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
+ (if (null? cmds)
+ (begin
+ (if M::producer (M::producer))
+ (if (not (null? M::procs))
+ (let* ((retcodes (wait-processes (map stringify (M::commands))
+ (M::pids) #t))
+ (results (map (lambda (p r) (append p (list r)))
+ M::procs retcodes))
+ (failed (filter (lambda (x) (not (= 0 (caddr x))))
+ results)))
+ (if (not (null? failed))
+ (throw failed))))) ; xxx nicer reporting
+ (if (and (= 2 (length cmds)) (number? (cadr cmds)))
+ ;; hack: if it's an fd, use it as sink
+ (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
+ (if (> M::source 2) (close M::source))
+ (if (> (cadr cmds) 2) (close (cadr cmds)))
+ (loop M' '()))
+ (let ((M' ((car cmds) M)))
+ (if (> M::source 2) (close M::source))
+ (loop M' (cdr cmds)))))))
+
+(define (pipe:open pathname flags)
+ (lambda (M)
+ (M::set-source (open pathname flags))))
+
+(define (pipe:defer producer)
+ (lambda (M)
+ (let* ((p (outbound-pipe))
+ (M' (M::set-source (:read-end p))))
+ (M'::set-producer (lambda ()
+ (producer (:write-end p))
+ (close (:write-end p)))))))
+(define (pipe:echo data)
+ (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
+
+(define (pipe:spawn command)
+ (lambda (M)
+ (define (do-spawn M new-source)
+ (let ((pid (spawn-process-fd command M::source M::sink
+ (if (> (*verbose*) 0)
+ STDERR_FILENO CLOSED_FD)))
+ (M' (M::set-source new-source)))
+ (M'::add-proc command pid)))
+ (if (= CLOSED_FD M::sink)
+ (let* ((p (pipe))
+ (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
+ (close (:write-end p))
+ (M'::set-sink CLOSED_FD))
+ (do-spawn M CLOSED_FD))))
+
+(define (pipe:splice sink)
+ (lambda (M)
+ (splice M::source sink)
+ (M::set-source CLOSED_FD)))
+
+(define (pipe:write-to pathname flags mode)
+ (open pathname flags mode))
+
+;;
+;; Monadic transformer support.
+;;
+
+(define (tr:do . commands)
+ (let loop ((tmpfiles '()) (source #f) (cmds commands))
+ (if (null? cmds)
+ (for-each remove-temporary-file tmpfiles)
+ (let* ((v ((car cmds) tmpfiles source))
+ (tmpfiles' (car v))
+ (sink (cadr v))
+ (error (caddr v)))
+ (if error
+ (begin
+ (for-each remove-temporary-file tmpfiles')
+ (apply throw error)))
+ (loop tmpfiles' sink (cdr cmds))))))
+
+(define (tr:open pathname)
+ (lambda (tmpfiles source)
+ (list tmpfiles pathname #f)))
+
+(define (tr:spawn input command)
+ (lambda (tmpfiles source)
+ (if (and (member '**in** command) (not source))
+ (fail (string-append (stringify cmd) " needs an input")))
+ (let* ((t (make-temporary-file))
+ (cmd (map (lambda (x)
+ (cond
+ ((equal? '**in** x) source)
+ ((equal? '**out** x) t)
+ (else x))) command)))
+ (catch (list (cons t tmpfiles) t *error*)
+ (call-popen cmd input)
+ (if (and (member '**out** command) (not (file-exists? t)))
+ (fail (string-append (stringify cmd)
+ " did not produce '" t "'.")))
+ (list (cons t tmpfiles) t #f)))))
+
+(define (tr:write-to pathname)
+ (lambda (tmpfiles source)
+ (rename source pathname)
+ (list tmpfiles pathname #f)))
+
+(define (tr:pipe-do . commands)
+ (lambda (tmpfiles source)
+ (let ((t (make-temporary-file)))
+ (apply pipe:do
+ `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
+ ,@commands
+ ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
+ (list (cons t tmpfiles) t #f))))
+
+(define (tr:assert-identity reference)
+ (lambda (tmpfiles source)
+ (if (not (file=? source reference))
+ (fail "mismatch"))
+ (list tmpfiles source #f)))
+
+(define (tr:assert-weak-identity reference)
+ (lambda (tmpfiles source)
+ (if (not (text-file=? source reference))
+ (fail "mismatch"))
+ (list tmpfiles source #f)))
+
+(define (tr:call-with-content function . args)
+ (lambda (tmpfiles source)
+ (catch (list tmpfiles source *error*)
+ (apply function `(,(call-with-input-file source read-all) ,@args)))
+ (list tmpfiles source #f)))
+
+;;
+;; Developing and debugging tests.
+;;
+
+;; Spawn an os shell.
+(define (interactive-shell)
+ (call-with-fds `(,(getenv "SHELL") -i) 0 1 2))
+
+;;
+;; The main test framework.
+;;
+
+(define semaphore
+ (package
+ (define (new n)
+ (package
+ (define (acquire!?)
+ (if (> n 0)
+ (begin
+ (set! n (- n 1))
+ #t)
+ #f))
+ (define (release!)
+ (set! n (+ n 1)))))))
+
+;; A pool of tests.
+(define test-pool
+ (package
+ (define (new n)
+ (package
+ ;; A semaphore to restrict the number of spawned processes.
+ (define sem (semaphore::new n))
+
+ ;; A list of enqueued, but not yet run tests.
+ (define enqueued '())
+
+ ;; A list of running or finished processes.
+ (define procs '())
+
+ (define (add test)
+ (if (test::started?)
+ (set! procs (cons test procs))
+ (if (sem::acquire!?)
+ (add (test::run-async))
+ (set! enqueued (cons test enqueued))))
+ (current-environment))
+
+ ;; Pop the last of the enqueued tests off the fifo queue.
+ (define (pop-test!)
+ (let ((i (length enqueued)))
+ (assert (> i 0))
+ (cond
+ ((= i 1)
+ (let ((test (car enqueued)))
+ (set! enqueued '())
+ test))
+ (else
+ (let* ((tail (list-tail enqueued (- i 2)))
+ (test (cadr tail)))
+ (set-cdr! tail '())
+ (assert (= (length enqueued) (- i 1)))
+ test)))))
+
+ (define (pid->test pid)
+ (let ((t (filter (lambda (x) (= pid x::pid)) procs)))
+ (if (null? t) #f (car t))))
+ (define (wait)
+ (if (null? enqueued)
+ ;; If no tests are enqueued, we can just block until all
+ ;; of them finished.
+ (wait' #t)
+ ;; Otherwise, we must not block, but give some tests the
+ ;; chance to finish so that we can start new ones.
+ (begin
+ (wait' #f)
+ (usleep (/ 1000000 10))
+ (wait))))
+ (define (wait' hang)
+ (let ((unfinished (filter (lambda (t) (not t::retcode)) procs)))
+ (if (null? unfinished)
+ (current-environment)
+ (let ((names (map (lambda (t) t::name) unfinished))
+ (pids (map (lambda (t) t::pid) unfinished))
+ (any #f))
+ (for-each
+ (lambda (test retcode)
+ (unless (< retcode 0)
+ (test::set-end-time!)
+ (test:::set! 'retcode retcode)
+ (test::report)
+ (sem::release!)
+ (set! any #t)))
+ (map pid->test pids)
+ (wait-processes (map stringify names) pids hang))
+
+ ;; If some processes finished, try to start new ones.
+ (let loop ()
+ (cond
+ ((not any) #f)
+ ((pair? enqueued)
+ (if (sem::acquire!?)
+ (let ((test (pop-test!)))
+ (add (test::run-async))
+ (loop)))))))))
+ (current-environment))
+ (define (filter-tests status)
+ (filter (lambda (p) (eq? status (p::status))) procs))
+ (define (report)
+ (define (print-tests tests message)
+ (unless (null? tests)
+ (apply echo (cons message
+ (map (lambda (t) t::name) tests)))))
+
+ (let ((failed (filter-tests 'FAIL))
+ (xfailed (filter-tests 'XFAIL))
+ (xpassed (filter-tests 'XPASS))
+ (skipped (filter-tests 'SKIP)))
+ (echo "===================")
+ (echo (length procs) "tests run,"
+ (length (filter-tests 'PASS)) "succeeded,"
+ (length failed) "failed,"
+ (length xfailed) "failed expectedly,"
+ (length xpassed) "succeeded unexpectedly,"
+ (length skipped) "skipped.")
+ (print-tests failed "Failed tests:")
+ (print-tests xfailed "Expectedly failed tests:")
+ (print-tests xpassed "Unexpectedly passed tests:")
+ (print-tests skipped "Skipped tests:")
+ (echo "===================")
+ (+ (length failed) (length xpassed))))
+
+ (define (xml)
+ (xx::document
+ (xx::tag 'testsuites
+ `((xmlns:xsi "http://www.w3.org/2001/XMLSchema-instance")
+ ("xsi:noNamespaceSchemaLocation"
+ "https://windyroad.com.au/dl/Open%20Source/JUnit.xsd"))
+ (map (lambda (t) (t::xml)) procs))))))))
+
+(define (verbosity n)
+ (if (= 0 n) '() (cons '--verbose (verbosity (- n 1)))))
+
+(define (locate-test path)
+ (if (absolute-path? path) path (in-srcdir path)))
+
+;; A single test.
+(define test
+ (begin
+
+ ;; Private definitions.
+
+ (define (isotime->junit t)
+ "[0-9]{4}-[0-9]{2}-[0-9]{2}T[0-9]{2}:[0-9]{2}:[0-9]{2}"
+ "20170418T145809"
+ (string-append (substring t 0 4)
+ "-"
+ (substring t 4 6)
+ "-"
+ (substring t 6 11)
+ ":"
+ (substring t 11 13)
+ ":"
+ (substring t 13 15)))
+
+ ;; If a tests name ends with a bang (!), it is expected to fail.
+ (define (expect-failure? name)
+ (string-suffix? name "!"))
+ ;; Strips the bang (if any).
+ (define (test-name name)
+ (if (expect-failure? name)
+ (substring name 0 (- (string-length name) 1))
+ name))
+
+ (package
+ (define (scm setup name path . args)
+ ;; Start the process.
+ (define (spawn-scm args' in out err)
+ (spawn-process-fd `(,*argv0* ,@(verbosity (*verbose*))
+ ,(locate-test (test-name path))
+ ,@(if setup (force setup) '())
+ ,@args' ,@args) in out err))
+ (new name #f spawn-scm #f #f CLOSED_FD (expect-failure? name)))
+
+ (define (binary setup name path . args)
+ ;; Start the process.
+ (define (spawn-binary args' in out err)
+ (spawn-process-fd `(,(test-name path)
+ ,@(if setup (force setup) '()) ,@args' ,@args)
+ in out err))
+ (new name #f spawn-binary #f #f CLOSED_FD (expect-failure? name)))
+
+ (define (new name directory spawn pid retcode logfd expect-failure)
+ (package
+
+ ;; XXX: OO glue.
+ (define self (current-environment))
+ (define (:set! key value)
+ (eval `(set! ,key ,value) (current-environment))
+ (current-environment))
+
+ ;; The log is written here.
+ (define log-file-name #f)
+
+ ;; Record time stamps.
+ (define timestamp #f)
+ (define start-time 0)
+ (define end-time 0)
+
+ (define (set-start-time!)
+ (set! timestamp (isotime->junit (get-isotime)))
+ (set! start-time (get-time)))
+ (define (set-end-time!)
+ (set! end-time (get-time)))
+
+ ;; Has the test been started yet?
+ (define (started?)
+ (number? pid))
+
+ (define (open-log-file)
+ (unless log-file-name
+ (set! log-file-name (string-append (basename name) ".log")))
+ (catch '() (unlink log-file-name))
+ (open log-file-name (logior O_RDWR O_BINARY O_CREAT) #o600))
+
+ (define (run-sync . args)
+ (set-start-time!)
+ (letfd ((log (open-log-file)))
+ (with-working-directory directory
+ (let* ((p (inbound-pipe))
+ (pid' (spawn args 0 (:write-end p) (:write-end p))))
+ (close (:write-end p))
+ (splice (:read-end p) STDERR_FILENO log)
+ (close (:read-end p))
+ (set! pid pid')
+ (set! retcode (wait-process name pid' #t)))))
+ (report)
+ (current-environment))
+ (define (run-sync-quiet . args)
+ (set-start-time!)
+ (with-working-directory directory
+ (set! pid (spawn args CLOSED_FD CLOSED_FD CLOSED_FD)))
+ (set! retcode (wait-process name pid #t))
+ (set-end-time!)
+ (current-environment))
+ (define (run-async . args)
+ (set-start-time!)
+ (let ((log (open-log-file)))
+ (with-working-directory directory
+ (set! pid (spawn args CLOSED_FD log log)))
+ (set! logfd log))
+ (current-environment))
+ (define (status)
+ (let* ((t' (assoc retcode '((0 PASS) (77 SKIP) (99 ERROR))))
+ (t (if (not t') 'FAIL (cadr t'))))
+ (if expect-failure
+ (case t ((PASS) 'XPASS) ((FAIL) 'XFAIL) (else t))
+ t)))
+ (define (status-string)
+ (cadr (assoc (status) '((PASS "PASS")
+ (SKIP "SKIP")
+ (ERROR "ERROR")
+ (FAIL "FAIL")
+ (XPASS "XPASS")
+ (XFAIL "XFAIL")))))
+ (define (report)
+ (unless (= logfd CLOSED_FD)
+ (seek logfd 0 SEEK_SET)
+ (splice logfd STDERR_FILENO)
+ (close logfd))
+ (echo (string-append (status-string) ":") name))
+
+ (define (xml)
+ (xx::tag
+ 'testsuite
+ `((name ,name)
+ (time ,(- end-time start-time))
+ (package ,(dirname name))
+ (id 0)
+ (timestamp ,timestamp)
+ (hostname "unknown")
+ (tests 1)
+ (failures ,(if (eq? FAIL (status)) 1 0))
+ (errors ,(if (eq? ERROR (status)) 1 0)))
+ (list
+ (xx::tag 'properties)
+ (xx::tag 'testcase
+ `((name ,(basename name))
+ (classname ,(string-translate (dirname name) "/" "."))
+ (time ,(- end-time start-time)))
+ `(,@(case (status)
+ ((PASS XFAIL) '())
+ ((SKIP) (list (xx::tag 'skipped)))
+ ((ERROR) (list
+ (xx::tag 'error '((message "Unknown error.")))))
+ (else
+ (list (xx::tag 'failure '((message "Unknown error."))))))))
+ (xx::tag 'system-out '()
+ (list (xx::textnode (read-all (open-input-file log-file-name)))))
+ (xx::tag 'system-err '() (list (xx::textnode "")))))))))))
+
+;; Run the setup target to create an environment, then run all given
+;; tests in parallel.
+(define (run-tests-parallel tests n)
+ (let loop ((pool (test-pool::new n)) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ ((results::xml) (open-output-file "report.xml"))
+ (exit (results::report)))
+ (let ((wd (mkdtemp-autoremove))
+ (test (car tests')))
+ (test:::set! 'directory wd)
+ (loop (pool::add test)
+ (cdr tests'))))))
+
+;; Run the setup target to create an environment, then run all given
+;; tests in sequence.
+(define (run-tests-sequential tests)
+ (let loop ((pool (test-pool::new 1)) (tests' tests))
+ (if (null? tests')
+ (let ((results (pool::wait)))
+ ((results::xml) (open-output-file "report.xml"))
+ (exit (results::report)))
+ (let ((wd (mkdtemp-autoremove))
+ (test (car tests')))
+ (test:::set! 'directory wd)
+ (loop (pool::add (test::run-sync))
+ (cdr tests'))))))
+
+;; Run tests either in sequence or in parallel, depending on the
+;; number of tests and the command line flags.
+(define (run-tests tests)
+ (let ((parallel (flag "--parallel" *args*))
+ (default-parallel-jobs 32))
+ (if (and parallel (> (length tests) 1))
+ (run-tests-parallel tests (if (and (pair? parallel)
+ (string->number (car parallel)))
+ (string->number (car parallel))
+ default-parallel-jobs))
+ (run-tests-sequential tests))))
+
+;; Load all tests from the given path.
+(define (load-tests . path)
+ (load (apply in-srcdir `(,@path "all-tests.scm")))
+ all-tests)
+
+;; Helper to create environment caches from test functions. SETUP
+;; must be a test implementing the producer side cache protocol.
+;; Returns a promise containing the arguments that must be passed to a
+;; test implementing the consumer side of the cache protocol.
+(define (make-environment-cache setup)
+ (delay (with-temporary-working-directory
+ (let ((tarball (make-temporary-file "environment-cache")))
+ (atexit (lambda () (remove-temporary-file tarball)))
+ (setup::run-sync '--create-tarball tarball)
+ (if (not (equal? 'PASS (setup::status)))
+ (fail "Setup failed."))
+ `(--unpack-tarball ,tarball)))))
+
+;; Command line flag handling. Returns the elements following KEY in
+;; ARGUMENTS up to the next argument, or #f if KEY is not in
+;; ARGUMENTS. If 'KEY=XYZ' is encountered, then the singleton list
+;; containing 'XYZ' is returned.
+(define (flag key arguments)
+ (cond
+ ((null? arguments)
+ #f)
+ ((string=? key (car arguments))
+ (let loop ((acc '())
+ (args (cdr arguments)))
+ (if (or (null? args) (string-prefix? (car args) "--"))
+ (reverse acc)
+ (loop (cons (car args) acc) (cdr args)))))
+ ((string-prefix? (car arguments) (string-append key "="))
+ (list (substring (car arguments)
+ (+ (string-length key) 1)
+ (string-length (car arguments)))))
+ ((string=? "--" (car arguments))
+ #f)
+ (else
+ (flag key (cdr arguments)))))
+(assert (equal? (flag "--xxx" '("--yyy")) #f))
+(assert (equal? (flag "--xxx" '("--xxx")) '()))
+(assert (equal? (flag "--xxx" '("--xxx" "yyy")) '("yyy")))
+(assert (equal? (flag "--xxx" '("--xxx=foo" "yyy")) '("foo")))
+(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz")) '("yyy" "zzz")))
+(assert (equal? (flag "--xxx" '("--xxx" "yyy" "zzz" "--")) '("yyy" "zzz")))
+(assert (equal? (flag "--xxx" '("--xxx" "yyy" "--" "zzz")) '("yyy")))
+(assert (equal? (flag "--" '("--" "xxx" "yyy" "--" "zzz")) '("xxx" "yyy")))
diff --git a/tests/gpgscm/time.scm b/tests/gpgscm/time.scm
new file mode 100644
index 0000000..a9b06d0
--- /dev/null
+++ b/tests/gpgscm/time.scm
@@ -0,0 +1,42 @@
+;; Simple time manipulation library.
+;;
+;; Copyright (C) 2017 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+;; This library mimics what GnuPG thinks about expiration times.
+;; Granularity is one second. Its focus is not on correctness.
+
+;; Conversion functions.
+(define (minutes->seconds minutes)
+ (* minutes 60))
+(define (hours->seconds hours)
+ (* hours 60 60))
+(define (days->seconds days)
+ (* days 24 60 60))
+(define (weeks->seconds weeks)
+ (days->seconds (* weeks 7)))
+(define (months->seconds months)
+ (days->seconds (* months 30)))
+(define (years->seconds years)
+ (days->seconds (* years 365)))
+
+(define (time-matches? a b slack)
+ (< (abs (- a b)) slack))
+(assert (time-matches? (hours->seconds 1) (hours->seconds 2) (hours->seconds 2)))
+(assert (time-matches? (hours->seconds 2) (hours->seconds 1) (hours->seconds 2)))
+(assert (not (time-matches? (hours->seconds 4) (hours->seconds 1) (hours->seconds 2))))
+(assert (not (time-matches? (hours->seconds 1) (hours->seconds 4) (hours->seconds 2))))
diff --git a/tests/gpgscm/xml.scm b/tests/gpgscm/xml.scm
new file mode 100644
index 0000000..771ec36
--- /dev/null
+++ b/tests/gpgscm/xml.scm
@@ -0,0 +1,142 @@
+;; A tiny XML library.
+;;
+;; Copyright (C) 2017 g10 Code GmbH
+;;
+;; This file is part of GnuPG.
+;;
+;; GnuPG is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+;;
+;; GnuPG 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 General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, see <http://www.gnu.org/licenses/>.
+
+(define xx
+ (begin
+
+ ;; Private declarations.
+ (define quote-text
+ '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")))
+
+ (define quote-attribute-'
+ '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\' "&apos;")))
+
+ (define quote-attribute-''
+ '((#\< "&lt;")
+ (#\> "&gt;")
+ (#\& "&amp;")
+ (#\" "&quot;")))
+
+ (define (escape-string quotation string sink)
+ ;; This implementation is a bit awkward because iteration is so
+ ;; slow in TinySCHEME. We rely on string-index to skip to the
+ ;; next character we need to escape. We also avoid allocations
+ ;; wherever possible.
+
+ ;; Given a list of integers or #f, return the sublist that
+ ;; starts with the lowest integer.
+ (define (min* x)
+ (let loop ((lowest x) (rest x))
+ (if (null? rest)
+ lowest
+ (loop (if (or (null? lowest) (not (car lowest))
+ (and (car rest) (> (car lowest) (car rest)))) rest lowest)
+ (cdr rest)))))
+
+ (let ((i 0) (start 0) (len (string-length string))
+ (indices (map (lambda (x) (string-index string (car x))) quotation))
+ (next #f) (c #f))
+
+ ;; Set 'i' to the index of the next character that needs
+ ;; escaping, 'c' to the character that needs to be escaped,
+ ;; and update 'indices'.
+ (define (skip!)
+ (set! next (min* indices))
+ (set! i (if (null? next) #f (car next)))
+ (if i
+ (begin
+ (set! c (string-ref string i))
+ (set-car! next (string-index string c (+ 1 i))))
+ (set! i (string-length string))))
+
+ (let loop ()
+ (skip!)
+ (if (< i len)
+ (begin
+ (display (substring string start i) sink)
+ (display (cadr (assv c quotation)) sink)
+ (set! i (+ 1 i))
+ (set! start i)
+ (loop))
+ (display (substring string start len) sink)))))
+
+ (let ((escape-string-s (lambda (quotation string)
+ (let ((sink (open-output-string)))
+ (escape-string quotation string sink)
+ (get-output-string sink)))))
+ (assert (equal? (escape-string-s quote-text "foo") "foo"))
+ (assert (equal? (escape-string-s quote-text "foo&") "foo&amp;"))
+ (assert (equal? (escape-string-s quote-text "&foo") "&amp;foo"))
+ (assert (equal? (escape-string-s quote-text "foo&bar") "foo&amp;bar"))
+ (assert (equal? (escape-string-s quote-text "foo<bar") "foo&lt;bar"))
+ (assert (equal? (escape-string-s quote-text "foo>bar") "foo&gt;bar")))
+
+ (define (escape quotation datum sink)
+ (cond
+ ((string? datum) (escape-string quotation datum sink))
+ ((symbol? datum) (escape-string quotation (symbol->string datum) sink))
+ ((number? datum) (display (number->string datum) sink))
+ (else
+ (throw "Do not know how to encode" datum))))
+
+ (define (name->string name)
+ (cond
+ ((symbol? name) (symbol->string name))
+ (else name)))
+
+ (package
+
+ (define (textnode string)
+ (lambda (sink)
+ (escape quote-text string sink)))
+
+ (define (tag name . rest)
+ (let ((attributes (if (null? rest) '() (car rest)))
+ (children (if (> (length rest) 1) (cadr rest) '())))
+ (lambda (sink)
+ (display "<" sink)
+ (display (name->string name) sink)
+ (unless (null? attributes)
+ (display " " sink)
+ (for-each (lambda (a)
+ (display (car a) sink)
+ (display "=\"" sink)
+ (escape quote-attribute-'' (cadr a) sink)
+ (display "\" " sink)) attributes))
+ (if (null? children)
+ (display "/>\n" sink)
+ (begin
+ (display ">\n" sink)
+ (for-each (lambda (c) (c sink)) children)
+ (display "</" sink)
+ (display (name->string name) sink)
+ (display ">\n" sink))))))
+
+ (define (document root . rest)
+ (let ((attributes (if (null? rest) '() (car rest))))
+ (lambda (sink)
+ ;; xxx ignores attributes
+ (display "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" sink)
+ (root sink)
+ (newline sink)))))))