diff --git a/gpgscm/Makefile.am b/gpgscm/Makefile.am
index 44d7b3f..59e1924 100644
--- a/gpgscm/Makefile.am
+++ b/gpgscm/Makefile.am
@@ -1,64 +1,64 @@
# TinyScheme-based test driver.
#
# Copyright (C) 2016 g10 Code GmbH
#
-# This file is part of GnuPG.
+# This file is part of Libgpg-error.
#
-# 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.
+# Libgpg-error is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Lesser General Public License
+# as published by the Free Software Foundation; either version 2.1 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.
+# Libgpg-error is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, see .
+# You should have received a copy of the GNU Lesser General Public
+# License along with this program; if not, see .
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/gpgscm/ffi-private.h b/gpgscm/ffi-private.h
index 037da56..5d82127 100644
--- a/gpgscm/ffi-private.h
+++ b/gpgscm/ffi-private.h
@@ -1,148 +1,147 @@
/* FFI interface for TinySCHEME.
- *
* Copyright (C) 2016 g10 code GmbH
*
- * This file is part of GnuPG.
+ * This file is part of Libgpg-error.
*
- * 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.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, see .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#ifndef GPGSCM_FFI_PRIVATE_H
#define GPGSCM_FFI_PRIVATE_H
#include
#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/gpgscm/ffi.c b/gpgscm/ffi.c
index dde5b52..5c8ff45 100644
--- a/gpgscm/ffi.c
+++ b/gpgscm/ffi.c
@@ -1,1470 +1,1469 @@
/* FFI interface for TinySCHEME.
+ * Copyright (C) 2016 g10 Code GmbH
*
- * Copyright (C) 2016 g10 code GmbH
+ * This file is part of Libgpg-error.
*
- * This file is part of GnuPG.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 of
+ * the License, or (at your option) any later version.
*
- * 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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 .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#if HAVE_LIBREADLINE
#define GNUPG_LIBREADLINE_H_INCLUDED
#include
#include
#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/gpgscm/ffi.h b/gpgscm/ffi.h
index eba6282..a7986e6 100644
--- a/gpgscm/ffi.h
+++ b/gpgscm/ffi.h
@@ -1,30 +1,29 @@
/* FFI interface for TinySCHEME.
+ * Copyright (C) 2016 g10 Code GmbH
*
- * Copyright (C) 2016 g10 code GmbH
+ * This file is part of Libgpg-error.
*
- * This file is part of GnuPG.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 of
+ * the License, or (at your option) any later version.
*
- * 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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 .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#ifndef GPGSCM_FFI_H
#define GPGSCM_FFI_H
#include
#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/gpgscm/ffi.scm b/gpgscm/ffi.scm
index 051c2c2..315aeb4 100644
--- a/gpgscm/ffi.scm
+++ b/gpgscm/ffi.scm
@@ -1,51 +1,51 @@
;; FFI interface for TinySCHEME.
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
+
;; 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/gpgscm/gnupg.scm b/gpgscm/gnupg.scm
index 5fcf9fd..57e0d83 100644
--- a/gpgscm/gnupg.scm
+++ b/gpgscm/gnupg.scm
@@ -1,44 +1,43 @@
;; Common definitions for executing gpg and related tools.
-;;
;; Copyright (C) 2016, 2017 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
;; 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 . expressions)
(let ((original-home-directory (gensym))
(ephemeral-home-directory (gensym))
(setup (gensym)))
`(let ((,original-home-directory (getenv "GNUPGHOME"))
(,ephemeral-home-directory (mkdtemp))
(,setup (delay (,setup-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" ,original-home-directory #t)))))))
diff --git a/gpgscm/lib.scm b/gpgscm/lib.scm
index 258f692..d45591f 100644
--- a/gpgscm/lib.scm
+++ b/gpgscm/lib.scm
@@ -1,307 +1,306 @@
;; Additional library functions for TinySCHEME.
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
(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/gpgscm/main.c b/gpgscm/main.c
index 5540ac3..a4963e2 100644
--- a/gpgscm/main.c
+++ b/gpgscm/main.c
@@ -1,359 +1,358 @@
/* TinyScheme-based test driver.
+ * Copyright (C) 2016 g10 Code GmbH
*
- * Copyright (C) 2016 g10 code GmbH
+ * This file is part of Libgpg-error.
*
- * This file is part of GnuPG.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 of
+ * the License, or (at your option) any later version.
*
- * 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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 .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#include
#if HAVE_MMAP
#include
#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)
{
int no_more_options = 0;
while (!no_more_options && optfile_parse (NULL, NULL, NULL, pargs, popts))
{
switch (pargs->r_opt)
{
case oVerbose:
verbose++;
break;
default:
pargs->err = 2;
break;
}
}
}
/* Print usage information and provide strings for help. */
static const char *
my_strusage( int level )
{
const char *p;
switch (level)
{
case 11: p = "gpgscm (@GNUPG@)";
break;
case 13: p = VERSION; 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);
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/gpgscm/makefile.scm b/gpgscm/makefile.scm
index 32fae3a..89241e5 100644
--- a/gpgscm/makefile.scm
+++ b/gpgscm/makefile.scm
@@ -1,76 +1,75 @@
;; Support for parsing Makefiles
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
(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/gpgscm/private.h b/gpgscm/private.h
index 6e330e0..5685314 100644
--- a/gpgscm/private.h
+++ b/gpgscm/private.h
@@ -1,26 +1,25 @@
/* TinyScheme-based test driver.
- *
* Copyright (C) 2016 g10 code GmbH
*
- * This file is part of GnuPG.
+ * This file is part of Libgpg-error.
*
- * 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.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this program; if not, see .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
-#ifndef __GPGSCM_PRIVATE_H__
-#define __GPGSCM_PRIVATE_H__
+#ifndef GPGSCM_PRIVATE_H
+#define GPGSCM_PRIVATE_H
extern int verbose;
-#endif /* __GPGSCM_PRIVATE_H__ */
+#endif /* GPGSCM_PRIVATE_H */
diff --git a/gpgscm/repl.scm b/gpgscm/repl.scm
index 833ec0d..8e87a97 100644
--- a/gpgscm/repl.scm
+++ b/gpgscm/repl.scm
@@ -1,69 +1,68 @@
;; A read-evaluate-print-loop for gpgscm.
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
;; 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/gpgscm/scheme-config.h b/gpgscm/scheme-config.h
index 15ca969..6b9610c 100644
--- a/gpgscm/scheme-config.h
+++ b/gpgscm/scheme-config.h
@@ -1,32 +1,31 @@
/* TinyScheme configuration.
+ * Copyright (C) 2016 g10 Code GmbH
*
- * Copyright (C) 2016 g10 code GmbH
+ * This file is part of Libgpg-error.
*
- * This file is part of GnuPG.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 of
+ * the License, or (at your option) any later version.
*
- * 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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 .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#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/gpgscm/scheme.c b/gpgscm/scheme.c
index 4384841..5102769 100644
--- a/gpgscm/scheme.c
+++ b/gpgscm/scheme.c
@@ -1,6028 +1,6030 @@
/* 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)
*
+ * This is a revised and modified version by g10 Code GmbH
+ * written by Justus Winter for use in GnuPG.
*/
#ifdef HAVE_CONFIG_H
# include
#endif
#define _SCHEME_SOURCE
#include "scheme-private.h"
#ifndef WIN32
# include
#endif
#ifdef WIN32
#define snprintf _snprintf
#endif
#if USE_DL
# include "dynload.h"
#endif
#if USE_MATH
# include
#endif
#include
#include
#include
#include
#include
#if USE_STRCASECMP
#include
# ifndef __APPLE__
# define stricmp strcasecmp
# endif
#endif
/* 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
#include
#include
#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");
}
/* 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.ivaluedce) {
return ce;
} else if(dfl-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_cntgensym_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, "");
}
#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; iNIL) {
p = "()";
} else if (l == sc->T) {
p = "#t";
} else if (l == sc->F) {
p = "#f";
} else if (l == sc->EOF_OBJ) {
p = "#";
} else if (is_port(l)) {
p = "#";
} 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 = "#";
} else if (is_closure(l)) {
p = "#";
} else if (is_promise(l)) {
p = "#";
} else if (is_foreign(l)) {
p = sc->strbuff;
snprintf(p,STRBUFFSIZE,"#", procnum(l));
} else if (is_continuation(l)) {
p = "#";
} 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 = "#";
}
*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 = "";
/* 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;
}
}
}
#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)) || index1args));
}
} 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,"#");
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);
}
}
}
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;
sc->reserved_lineno = 0;
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; iLAMBDA = 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 [ ...]\n");
printf("followed by\n");
printf(" -1 [ ...]\n");
printf(" -c [ ...]\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/gpgscm/small-integers.h b/gpgscm/small-integers.h
index 46eda34..13e3167 100644
--- a/gpgscm/small-integers.h
+++ b/gpgscm/small-integers.h
@@ -1,847 +1,838 @@
/* Constant integer objects for TinySCHEME.
*
- * Copyright (C) 2017 g10 code GmbH
+ * This file is free software; as a special exception the author gives
+ * unlimited permission to copy and/or distribute it, with or without
+ * modifications, as long as this notice is preserved.
*
- * 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 .
+ * This file 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.
*/
/*
* 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/gpgscm/t-child.c b/gpgscm/t-child.c
index f4e3a04..8823431 100644
--- a/gpgscm/t-child.c
+++ b/gpgscm/t-child.c
@@ -1,74 +1,73 @@
/* Sanity check for the process and IPC primitives.
+ * Copyright (C) 2016 g10 Code GmbH
*
- * Copyright (C) 2016 g10 code GmbH
+ * This file is part of Libgpg-error.
*
- * This file is part of GnuPG.
+ * Libgpg-error is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 2.1 of
+ * the License, or (at your option) any later version.
*
- * 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.
+ * Libgpg-error is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * 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 .
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this program; if not, see .
*/
#include
#include
#include
#ifdef _WIN32
# include
# include
#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/gpgscm/t-child.scm b/gpgscm/t-child.scm
index fd1dcc3..29e68a7 100644
--- a/gpgscm/t-child.scm
+++ b/gpgscm/t-child.scm
@@ -1,118 +1,117 @@
;; Tests for the low-level process and IPC primitives.
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
(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/gpgscm/tests.scm b/gpgscm/tests.scm
index 5141002..b88ddd3 100644
--- a/gpgscm/tests.scm
+++ b/gpgscm/tests.scm
@@ -1,886 +1,885 @@
;; Common definitions for writing tests.
-;;
;; Copyright (C) 2016 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
;; 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 )
;;
;; Bind all variables given in and initialize each of them
;; to the given initial value, and close them after evaluating .
(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 )
;;
;; Bind all variables given in , initialize each of them to
;; a string representing an unique path in the filesystem, and delete
;; them after evaluating .
(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/gpgscm/time.scm b/gpgscm/time.scm
index a9b06d0..d357730 100644
--- a/gpgscm/time.scm
+++ b/gpgscm/time.scm
@@ -1,42 +1,41 @@
;; Simple time manipulation library.
-;;
;; Copyright (C) 2017 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
;; 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/gpgscm/xml.scm b/gpgscm/xml.scm
index 771ec36..a0ee70a 100644
--- a/gpgscm/xml.scm
+++ b/gpgscm/xml.scm
@@ -1,142 +1,141 @@
;; A tiny XML library.
-;;
;; Copyright (C) 2017 g10 Code GmbH
;;
-;; This file is part of GnuPG.
+;; This file is part of Libgpg-error.
;;
-;; 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.
+;; Libgpg-error is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 2.1 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.
+;; Libgpg-error is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, see .
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this program; if not, see .
(define xx
(begin
;; Private declarations.
(define quote-text
'((#\< "<")
(#\> ">")
(#\& "&")))
(define quote-attribute-'
'((#\< "<")
(#\> ">")
(#\& "&")
(#\' "'")))
(define quote-attribute-''
'((#\< "<")
(#\> ">")
(#\& "&")
(#\" """)))
(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&"))
(assert (equal? (escape-string-s quote-text "&foo") "&foo"))
(assert (equal? (escape-string-s quote-text "foo&bar") "foo&bar"))
(assert (equal? (escape-string-s quote-text "foobar") "foo>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 "string name) sink)
(display ">\n" sink))))))
(define (document root . rest)
(let ((attributes (if (null? rest) '() (car rest))))
(lambda (sink)
;; xxx ignores attributes
(display "\n" sink)
(root sink)
(newline sink)))))))