gnupg/tests/gpgscm/ffi.c

/* FFI interface for TinySCHEME.
 *
 * Copyright (C) 2016 g10 code GmbH
 *
 * This file is part of GnuPG.
 *
 * GnuPG is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 3 of the License, or
 * (at your option) any later version.
 *
 * GnuPG is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; if not, see <https://www.gnu.org/licenses/>.
 */

#include <config.h>

#include <assert.h>
#include <ctype.h>
#include <dirent.h>
#include <errno.h>
#include <fcntl.h>
#include <gpg-error.h>
#include <limits.h>
#include <stdarg.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>

#if HAVE_LIBREADLINE
#define GNUPG_LIBREADLINE_H_INCLUDED
#include <readline/readline.h>
#include <readline/history.h>
#endif

#include "../../common/util.h"
#ifdef HAVE_W32_SYSTEM
#define NEED_STRUCT_SPAWN_CB_ARG
#endif
#include "../../common/exechelp.h"
#include "../../common/sysutils.h"

#ifdef HAVE_W32_SYSTEM
#include <windows.h>
#endif

#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, gpg_error_from_syserror ());
  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");
  else
    {
      size_t len = strlen (buffer);
      buffer[len-1] = 0;
    }
  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,
  };

#if 0
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);
}
#endif

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.  */

struct proc_object_box
{
  gnupg_process_t proc;
};

static void
proc_object_finalize (scheme *sc, void *data)
{
  struct proc_object_box *box = data;
  (void) sc;

  if (!box->proc)
    gnupg_process_release (box->proc);
  xfree (box);
}

static void
proc_object_to_string (scheme *sc, char *out, size_t size, void *data)
{
  struct proc_object_box *box = data;
  (void) sc;

  snprintf (out, size, "#proc %p", box->proc);
}

static struct foreign_object_vtable proc_object_vtable =
  {
    proc_object_finalize,
    proc_object_to_string,
  };

static pointer
proc_wrap (scheme *sc, gnupg_process_t proc)
{
  struct proc_object_box *box = xmalloc (sizeof *box);
  if (box == NULL)
    return sc->NIL;

  box->proc = proc;
  return sc->vptr->mk_foreign_object (sc, &proc_object_vtable, box);
}

static struct proc_object_box *
proc_unwrap (scheme *sc, pointer object)
{
  (void) sc;

  if (! is_foreign_object (object))
    return NULL;

  if (sc->vptr->get_foreign_object_vtable (object) != &proc_object_vtable)
    return NULL;

  return sc->vptr->get_foreign_object_data (object);
}

#define CONVERSION_proc(SC, X)	proc_unwrap (SC, X)
#define IS_A_proc(SC, X)		proc_unwrap (SC, X)


#define SPAWN_IO_BUFSIZE 4096

#ifdef HAVE_W32_SYSTEM
struct rfp {
  HANDLE hd;
  char *buf;
  size_t len;
  off_t off;
};

static DWORD __attribute__((stdcall))
read_from_pipe (void *arg)
{
  struct rfp *rfp = arg;
  DWORD bytes_read;

  if (rfp->hd == INVALID_HANDLE_VALUE)
    goto errout;

  while (1)
    {
      if (!ReadFile (rfp->hd, rfp->buf + rfp->off, rfp->len - rfp->off,
                     &bytes_read, NULL))
        {
          DWORD ec = GetLastError ();

          if (ec == ERROR_BROKEN_PIPE)
            {
              CloseHandle (rfp->hd);
              rfp->hd = INVALID_HANDLE_VALUE;
              break;
            }

          goto errout;
        }

      if (bytes_read == 0)
        /* It may occur, when it writes WriteFile with zero-byte on
           the other end of the pipe. */
        continue;
      else
        {
          rfp->off += bytes_read;
          if (rfp->off == rfp->len)
            {
              rfp->len += SPAWN_IO_BUFSIZE;
              rfp->buf = xtryrealloc (rfp->buf, rfp->len);
              if (rfp->buf == NULL)
                goto errout;
            }
        }
    }

  return 0;

 errout:
  if (rfp->hd != INVALID_HANDLE_VALUE)
    {
      CloseHandle (rfp->hd);
      rfp->hd = INVALID_HANDLE_VALUE;
    }
  xfree (rfp->buf);
  rfp->buf = NULL;
  return 1;
}
#endif


static pointer
do_process_spawn_io (scheme *sc, pointer args)
{
  FFI_PROLOG ();
  pointer arguments;
  char *a_input;
  char **argv;
  size_t len;
  unsigned int flags;
  gnupg_process_t proc = NULL;
  estream_t infp;
#ifdef HAVE_W32_SYSTEM
  HANDLE out_hd, err_hd;
#else
  int out_fd, err_fd;
#endif
  char *out_string = NULL;
  char *err_string = NULL;
  size_t out_len = SPAWN_IO_BUFSIZE;
  size_t err_len = SPAWN_IO_BUFSIZE;
  off_t out_off = 0;
  off_t err_off = 0;
  int retcode = -1;
  pointer p0, p1, p2;

  FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
  FFI_ARG_OR_RETURN (sc, char *, a_input, string, args);
  flags = (GNUPG_PROCESS_STDIN_PIPE
           | GNUPG_PROCESS_STDOUT_PIPE
           | GNUPG_PROCESS_STDERR_PIPE);
  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_process_spawn (argv[0], (const char **) &argv[1],
                             flags, NULL, NULL, &proc);
  err = gnupg_process_get_streams (proc, 0, &infp, NULL, NULL);

  err = es_write (infp, a_input, strlen (a_input), NULL);
  es_fclose (infp);
  if (err)
    {
      gnupg_process_release (proc);
      xfree (argv);
      FFI_RETURN_ERR (sc, err);
    }

#ifdef HAVE_W32_SYSTEM
  err = gnupg_process_ctl (proc, GNUPG_PROCESS_GET_HANDLES,
                           NULL, &out_hd, &err_hd);
#else
  err = gnupg_process_get_fds (proc, 0, NULL, &out_fd, &err_fd);
#endif
  if (err)
    {
      gnupg_process_release (proc);
      xfree (argv);
      FFI_RETURN_ERR (sc, err);
    }

  out_string = xtrymalloc (out_len);
  if (out_string == NULL)
    goto errout;

  err_string = xtrymalloc (err_len);
  if (err_string == NULL)
    goto errout;

#ifdef HAVE_W32_SYSTEM
  {
    HANDLE h_thread_rfp_err;
    struct rfp rfp_out;
    struct rfp rfp_err;
    DWORD thread_exit_code;

    rfp_err.hd = err_hd;
    rfp_err.buf = err_string;
    rfp_err.len = err_len;
    rfp_err.off = 0;
    err_hd = INVALID_HANDLE_VALUE;
    err_string = NULL;

    h_thread_rfp_err = CreateThread (NULL, 0, read_from_pipe, (void *)&rfp_err,
                                     0, NULL);
    if (h_thread_rfp_err == NULL)
      {
        xfree (rfp_err.buf);
        CloseHandle (rfp_err.hd);
        goto errout;
      }

    rfp_out.hd = out_hd;
    rfp_out.buf = out_string;
    rfp_out.len = out_len;
    rfp_out.off = 0;
    out_hd = INVALID_HANDLE_VALUE;
    out_string = NULL;

    if (read_from_pipe (&rfp_out))
      {
        CloseHandle (h_thread_rfp_err);
        xfree (rfp_err.buf);
        goto errout;
      }

    out_string = rfp_out.buf;
    out_off = rfp_out.off;

    WaitForSingleObject (h_thread_rfp_err, INFINITE);
    GetExitCodeThread (h_thread_rfp_err, &thread_exit_code);
    CloseHandle (h_thread_rfp_err);
    if (thread_exit_code)
      goto errout;

    err_string = rfp_err.buf;
    err_off = rfp_err.off;
  }
#else
  {
    fd_set read_fdset;
    ssize_t bytes_read;

    while (1)
      {
        int nfd;
        int ret;

        FD_ZERO (&read_fdset);

        if (out_fd >= 0)
          FD_SET (out_fd, &read_fdset);

        if (err_fd >= 0)
          FD_SET (err_fd, &read_fdset);

        if (out_fd > err_fd)
          nfd = out_fd;
        else
          nfd = err_fd;

        if (nfd == -1)
          break;

        ret = select (nfd+1, &read_fdset, NULL, NULL, NULL);
        if (ret < 0)
          break;

        if (FD_ISSET (out_fd, &read_fdset))
          {
            bytes_read = read (out_fd, out_string + out_off,
                               out_len - out_off);
            if (bytes_read == 0)
              {
                close (out_fd);
                out_fd = -1;
              }
            else if (bytes_read < 0)
              goto errout;
            else
              {
                out_off += bytes_read;
                if (out_off == out_len)
                  {
                    out_len += SPAWN_IO_BUFSIZE;
                    out_string = xtryrealloc (out_string, out_len);
                    if (out_string == NULL)
                      goto errout;
                  }
              }
          }

        if (FD_ISSET (err_fd, &read_fdset))
          {
            bytes_read = read (err_fd, err_string + err_off,
                               err_len - err_off);
            if (bytes_read == 0)
              {
                close (err_fd);
                err_fd = -1;
              }
            else if (bytes_read < 0)
              goto errout;
            else
              {
                err_off += bytes_read;
                if (err_off == err_len)
                  {
                    err_len += SPAWN_IO_BUFSIZE;
                    err_string = xtryrealloc (err_string, err_len);
                    if (err_string == NULL)
                      goto errout;
                  }
              }
          }
      }
  }
#endif

  err = gnupg_process_wait (proc, 1);
  if (!err)
    err = gnupg_process_ctl (proc, GNUPG_PROCESS_GET_EXIT_ID, &retcode);

  gnupg_process_release (proc);
  xfree (argv);

  p0 = sc->vptr->mk_integer (sc, (unsigned long)retcode);
  p1 = sc->vptr->mk_counted_string (sc, out_string, out_off);
  p2 = sc->vptr->mk_counted_string (sc, err_string, err_off);

  xfree (out_string);
  xfree (err_string);

  FFI_RETURN_POINTER (sc, _cons (sc, p0,
                                 _cons (sc, p1,
                                        _cons (sc, p2, sc->NIL, 1), 1), 1));
 errout:
  xfree (out_string);
  xfree (err_string);
#ifdef HAVE_W32_SYSTEM
  if (out_hd != INVALID_HANDLE_VALUE)
    CloseHandle (out_hd);
  if (err_hd != INVALID_HANDLE_VALUE)
    CloseHandle (err_hd);
#else
  if (out_fd >= 0)
    close (out_fd);
  if (err_fd >= 0)
    close (err_fd);
#endif
  gnupg_process_release (proc);
  xfree (argv);
  FFI_RETURN_ERR (sc, err);
}

static void
setup_std_fds (struct spawn_cb_arg *sca)
{
  int *std_fds = sca->arg;

#ifdef HAVE_W32_SYSTEM
  sca->hd[0] = std_fds[0] == -1?
    INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[0]);
  sca->hd[1] = std_fds[1] == -1?
    INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[1]);
  sca->hd[2] = std_fds[2] == -1?
    INVALID_HANDLE_VALUE : (HANDLE)_get_osfhandle (std_fds[2]);
#else
  sca->fds[0] = std_fds[0];
  sca->fds[1] = std_fds[1];
  sca->fds[2] = std_fds[2];
#endif
}

static pointer
do_process_spawn_fd (scheme *sc, pointer args)
{
  FFI_PROLOG ();
  pointer arguments;
  char **argv;
  size_t len;
  int std_fds[3];
  gnupg_process_t proc = NULL;

  FFI_ARG_OR_RETURN (sc, pointer, arguments, list, args);
  FFI_ARG_OR_RETURN (sc, int, std_fds[0], number, args);
  FFI_ARG_OR_RETURN (sc, int, std_fds[1], number, args);
  FFI_ARG_OR_RETURN (sc, int, std_fds[2], 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, " (%d %d %d)\n", std_fds[0], std_fds[1], std_fds[2]);
    }

  err = gnupg_process_spawn (argv[0], (const char **) &argv[1],
                             0, setup_std_fds, std_fds, &proc);
  xfree (argv);
  FFI_RETURN_POINTER (sc, proc_wrap (sc, proc));
}

static pointer
do_process_wait (scheme *sc, pointer args)
{
  FFI_PROLOG ();
  struct proc_object_box *box;
  int hang;
  int retcode = -1;

  FFI_ARG_OR_RETURN (sc, struct proc_object_box *, box, proc, args);
  FFI_ARG_OR_RETURN (sc, int, hang, bool, args);
  FFI_ARGS_DONE_OR_RETURN (sc, args);
  err = gnupg_process_wait (box->proc, hang);
  if (!err)
    err = gnupg_process_ctl (box->proc, GNUPG_PROCESS_GET_EXIT_ID, &retcode);
  if (err == GPG_ERR_TIMEOUT)
    err = 0;

  FFI_RETURN_INT (sc, retcode);
}

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, pipe);
  ffi_define_function (sc, inbound_pipe);
  ffi_define_function (sc, outbound_pipe);
  ffi_define_function (sc, process_spawn_io);
  ffi_define_function (sc, process_spawn_fd);
  ffi_define_function (sc, process_wait);

  /* 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;
}