drop old patch series

6 files changed, 0 insertions, 11257 deletions

diff --git a/debian/patches/0001-libshouldbeinlibc-provide-mach_print-XXX.patch b/debian/patches/0001-libshouldbeinlibc-provide-mach_print-XXX.patch
deleted file mode 100644
index d0e30df2..00000000
--- a/debian/patches/0001-libshouldbeinlibc-provide-mach_print-XXX.patch
+++ /dev/null
@@ -1,78 +0,0 @@
-From ba752d8b8e1a9125b3001ff6b2fb7135dff675b6 Mon Sep 17 00:00:00 2001
-From: Justus Winter <4winter@informatik.uni-hamburg.de>
-Date: Tue, 13 Jan 2015 17:18:17 +0100
-Subject: [PATCH hurd 1/5] libshouldbeinlibc: provide `mach_print' XXX
-
-* libshouldbeinlibc/mach-print.c: New file.
-* libshouldbeinlibc/mach-print.h: Likewise.
-* libshouldbeinlibc/Makefile: Add `mach-print.{c,h}'.
----
- libshouldbeinlibc/Makefile     |  2 ++
- libshouldbeinlibc/mach-print.c | 28 ++++++++++++++++++++++++++++
- libshouldbeinlibc/mach-print.h |  2 ++
- 3 files changed, 32 insertions(+)
- create mode 100644 libshouldbeinlibc/mach-print.c
- create mode 100644 libshouldbeinlibc/mach-print.h
-
-diff --git a/libshouldbeinlibc/Makefile b/libshouldbeinlibc/Makefile
-index 633d60e..7a17d0e 100644
---- a/libshouldbeinlibc/Makefile
-+++ b/libshouldbeinlibc/Makefile
-@@ -29,10 +29,12 @@ SRCS = termsize.c timefmt.c exec-reauth.c maptime-funcs.c \
-        ugids-auth.c ugids-xinl.c ugids-merge.c ugids-imply.c ugids-posix.c \
-        ugids-verify-auth.c nullauth.c \
-        refcount.c \
-+       mach-print.c \
- 
- installhdrs = idvec.h timefmt.h maptime.h \
- 	      wire.h portinfo.h portxlate.h cacheq.h ugids.h nullauth.h \
- 	      refcount.h \
-+	      mach-print.h \
- 
- installhdrsubdir = .
- 
-diff --git a/libshouldbeinlibc/mach-print.c b/libshouldbeinlibc/mach-print.c
-new file mode 100644
-index 0000000..b417d9d
---- /dev/null
-+++ b/libshouldbeinlibc/mach-print.c
-@@ -0,0 +1,28 @@
-+#include <stdio.h>
-+#include <stdarg.h>
-+
-+#define BUFFER_SIZE 1024
-+
-+asm (".global _mach_print;"
-+     " _mach_print:;"
-+     " mov $0xffffffe2, %eax;"
-+     " lcall $0x7, $0x0;"
-+     " ret;");
-+
-+void
-+mach_print(const char *msg)
-+{
-+  _mach_print (msg);
-+}
-+
-+void
-+mach_printf (const char *format, ...)
-+{
-+  va_list ap;
-+  char buf[BUFFER_SIZE];
-+
-+  va_start(ap, format);
-+  vsnprintf(buf, sizeof(buf), format, ap);
-+  mach_print(buf);
-+  va_end(ap);
-+}
-diff --git a/libshouldbeinlibc/mach-print.h b/libshouldbeinlibc/mach-print.h
-new file mode 100644
-index 0000000..a733939
---- /dev/null
-+++ b/libshouldbeinlibc/mach-print.h
-@@ -0,0 +1,2 @@
-+void mach_print(const char *);
-+void mach_printf(const char *format, ...); // XXX attribute printf
--- 
-2.1.4
-
diff --git a/debian/patches/0002-libdiskfs-fixes-XXX.patch b/debian/patches/0002-libdiskfs-fixes-XXX.patch
deleted file mode 100644
index a2cf89a7..00000000
--- a/debian/patches/0002-libdiskfs-fixes-XXX.patch
+++ /dev/null
@@ -1,66 +0,0 @@
-From 90d7aaf2a272cf726d54ad000f502fae8c69e7b0 Mon Sep 17 00:00:00 2001
-From: Justus Winter <4winter@informatik.uni-hamburg.de>
-Date: Tue, 13 Jan 2015 18:59:29 +0100
-Subject: [PATCH hurd 2/5] libdiskfs: fixes XXX
-
----
- libdiskfs/boot-start.c   |  3 ++-
- libdiskfs/init-init.c    | 10 +++++-----
- libdiskfs/init-startup.c |  3 ++-
- 3 files changed, 9 insertions(+), 7 deletions(-)
-
-diff --git a/libdiskfs/boot-start.c b/libdiskfs/boot-start.c
-index 9be8ed2..302a403 100644
---- a/libdiskfs/boot-start.c
-+++ b/libdiskfs/boot-start.c
-@@ -465,7 +465,8 @@ diskfs_S_fsys_init (struct diskfs_control *pt,
-   struct peropen *rootpo;
- 
-   if (!pt
--      || pt->pi.class != diskfs_initboot_class)
-+      || (pt->pi.class != diskfs_initboot_class
-+          && pt->pi.class != diskfs_control_class)) // XXX
-     return EOPNOTSUPP;
-   
-   if (initdone)
-diff --git a/libdiskfs/init-init.c b/libdiskfs/init-init.c
-index 7a7f248..bc25bbe 100644
---- a/libdiskfs/init-init.c
-+++ b/libdiskfs/init-init.c
-@@ -71,14 +71,14 @@ diskfs_init_diskfs (void)
- 	  diskfs_default_pager = MACH_PORT_NULL;
- 	  err = vm_set_default_memory_manager (host, &diskfs_default_pager);
- 	  mach_port_deallocate (mach_task_self (), host);
--
--	  if (!err)
--	    err = maptime_map (1, 0, &diskfs_mtime);
- 	}
-+      if (err)
-+	return err;
-     }
--  else
--    err = maptime_map (0, 0, &diskfs_mtime);
- 
-+  err = maptime_map (0, 0, &diskfs_mtime);
-+  if (err)
-+    err = maptime_map (1, 0, &diskfs_mtime);
-   if (err)
-     return err;
- 
-diff --git a/libdiskfs/init-startup.c b/libdiskfs/init-startup.c
-index 3a588e1..a3a0d2d 100644
---- a/libdiskfs/init-startup.c
-+++ b/libdiskfs/init-startup.c
-@@ -106,7 +106,8 @@ diskfs_startup_diskfs (mach_port_t bootstrap, int flags)
-       mach_port_deallocate (mach_task_self (), bootstrap);
-       _diskfs_ncontrol_ports++;
- 
--      _diskfs_init_completed ();
-+      if (MACH_PORT_VALID (getproc ())) //XXX
-+        _diskfs_init_completed ();
-     }
-   else
-     {
--- 
-2.1.4
-
diff --git a/debian/patches/0003-trans-add-startup-standalone-XXX.patch b/debian/patches/0003-trans-add-startup-standalone-XXX.patch
deleted file mode 100644
index c187c28f..00000000
--- a/debian/patches/0003-trans-add-startup-standalone-XXX.patch
+++ /dev/null
@@ -1,493 +0,0 @@
-From a8c0a69d53d3dc310536a338e6d3ab34f75bb9cb Mon Sep 17 00:00:00 2001
-From: Justus Winter <4winter@informatik.uni-hamburg.de>
-Date: Tue, 13 Jan 2015 19:01:50 +0100
-Subject: [PATCH hurd 3/5] trans: add `startup-standalone' XXX
-
-Provide a stripped-down version of the startup translator that
-supervises core servers and handles system shutdown.
-
-* trans/startup-standalone.c: New file.
-* trans/Makefile: Add `startup-standalone'.
----
- trans/Makefile             |   9 +-
- trans/startup-standalone.c | 435 +++++++++++++++++++++++++++++++++++++++++++++
- 2 files changed, 440 insertions(+), 4 deletions(-)
- create mode 100644 trans/startup-standalone.c
-
-diff --git a/trans/Makefile b/trans/Makefile
-index ce1eae7..5153361 100644
---- a/trans/Makefile
-+++ b/trans/Makefile
-@@ -21,14 +21,14 @@ makemode := servers
- 
- targets = symlink firmlink ifsock magic null fifo new-fifo fwd crash \
- 	  password hello hello-mt streamio fakeroot proxy-defpager remap \
--	  mtab
-+	  mtab startup-standalone
- SRCS = ifsock.c symlink.c magic.c null.c fifo.c new-fifo.c fwd.c \
- 	crash.c firmlink.c password.c hello.c hello-mt.c streamio.c \
--	fakeroot.c proxy-defpager.c remap.c mtab.c
-+	fakeroot.c proxy-defpager.c remap.c mtab.c startup-standalone.c
- OBJS = $(SRCS:.c=.o) fsysServer.o ifsockServer.o passwordServer.o \
- 	crashServer.o crash_replyUser.o msgServer.o \
- 	default_pagerServer.o default_pagerUser.o \
--	device_replyServer.o elfcore.o
-+	device_replyServer.o elfcore.o startupServer.o
- HURDLIBS = ports netfs trivfs iohelp fshelp pipe ihash shouldbeinlibc
- LDLIBS += -lpthread
- password-LDLIBS = -lcrypt
-@@ -61,8 +61,9 @@ crash: crashServer.o crash_replyUser.o msgServer.o elfcore.o
- password: passwordServer.o
- streamio: device_replyServer.o
- proxy-defpager: default_pagerServer.o default_pagerUser.o
-+startup-standalone: startupServer.o startup_notifyUser.o
- 
--proxy-defpager crash password streamio: ../libports/libports.a ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a
-+proxy-defpager crash password streamio startup-standalone: ../libports/libports.a ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a
- fifo new-fifo: ../libpipe/libpipe.a
- fwd: ../libfshelp/libfshelp.a ../libports/libports.a
- hello-mt magic null ifsock fifo new-fifo firmlink: ../libtrivfs/libtrivfs.a ../libfshelp/libfshelp.a ../libports/libports.a ../libihash/libihash.a
-diff --git a/trans/startup-standalone.c b/trans/startup-standalone.c
-new file mode 100644
-index 0000000..87acd0e
---- /dev/null
-+++ b/trans/startup-standalone.c
-@@ -0,0 +1,435 @@
-+/* Start and maintain hurd core servers and system run state
-+
-+   Copyright (C) 1993-2015 Free Software Foundation, Inc.
-+   This file is part of the GNU Hurd.
-+
-+   The GNU Hurd 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 2, or (at your option)
-+   any later version.
-+
-+   The GNU Hurd 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 the GNU Hurd; see the file COPYING.  If not, write to
-+   the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
-+
-+/* Written by Michael I. Bushnell and Roland McGrath.  */
-+
-+/* This is probably more include files than I've ever seen before for
-+   one file. */
-+
-+#include <argp.h>
-+#include <argz.h>
-+#include <error.h>
-+#include <fcntl.h>
-+#include <hurd/ports.h>
-+#include <hurd/trivfs.h>
-+#include <stdlib.h>
-+#include <stdio.h>
-+#include <string.h>
-+#include <sys/mman.h>
-+#include <sys/reboot.h>
-+#include <unistd.h>
-+#include <version.h>
-+
-+#include "startup_notify_U.h"
-+#include "startup_reply_U.h"
-+#include "startup_S.h"
-+#include "notify_S.h"
-+
-+/* The privileged host control port.  Used for authentication.	*/
-+mach_port_t host_priv;
-+
-+/* We receive dead-name notifications here.  */
-+struct port_info *notification;
-+
-+/* host_reboot flags for when we crash.	 */
-+static int crash_flags = RB_AUTOBOOT;
-+
-+#define BOOT(flags)	((flags & RB_HALT) ? "halt" : "reboot")
-+
-+const char *argp_program_version = STANDARD_HURD_VERSION (startup-standalone);
-+
-+/* Trivfs hooks. */
-+int trivfs_fstype = FSTYPE_MISC;
-+int trivfs_fsid = 0;
-+
-+int trivfs_allow_open = 0;
-+int trivfs_support_read = 0;
-+int trivfs_support_write = 0;
-+int trivfs_support_exec = 0;
-+
-+void
-+trivfs_modify_stat (struct trivfs_protid *cred, struct stat *st)
-+{
-+  /* Mark the node as a read-only plain file. */
-+  st->st_mode &= ~(S_IFMT | ALLPERMS);
-+  st->st_mode |= (S_IFREG | S_IRUSR | S_IRGRP | S_IROTH);
-+  st->st_size = 0;
-+}
-+
-+error_t
-+trivfs_goaway (struct trivfs_control *cntl, int flags)
-+{
-+  exit (0);
-+}
-+
-+/* Options processing.	We accept the same options on the command line
-+   and from fsys_set_options.  */
-+
-+static const struct argp_option options[] =
-+{
-+  {"crash-debug",  'H', 0, 0, "On system crash, go to kernel debugger"},
-+  {0}
-+};
-+
-+static error_t
-+parse_opt (int opt, char *arg, struct argp_state *state)
-+{
-+  switch (opt)
-+    {
-+    case 'H': crash_flags = RB_DEBUGGER; break;
-+    default:
-+      return ARGP_ERR_UNKNOWN;
-+    case ARGP_KEY_INIT:
-+    case ARGP_KEY_SUCCESS:
-+    case ARGP_KEY_ERROR:
-+      break;
-+    }
-+  return 0;
-+}
-+
-+/* This will be called from libtrivfs to help construct the answer
-+   to an fsys_get_options RPC.	*/
-+error_t
-+trivfs_append_args (struct trivfs_control *fsys,
-+		    char **argz, size_t *argz_len)
-+{
-+  error_t err = 0;
-+
-+  if (crash_flags == RB_DEBUGGER)
-+    err = argz_add (argz, argz_len, "--crash-debug");
-+
-+  return err;
-+}
-+
-+static const char doc[] =
-+  "Supervise Hurd core servers and manage system shutdown";
-+
-+static struct argp hello_argp =
-+{ options, parse_opt, 0, doc };
-+
-+/* Setting this variable makes libtrivfs use our argp to
-+   parse options passed in an fsys_set_options RPC.  */
-+struct argp *trivfs_runtime_argp = &hello_argp;
-+
-+static int
-+demuxer (mach_msg_header_t *inp,
-+	 mach_msg_header_t *outp)
-+{
-+  // XXX nicer demuxer
-+  extern int startup_server (mach_msg_header_t *, mach_msg_header_t *);
-+
-+  return startup_server (inp, outp) || trivfs_demuxer (inp, outp);
-+}
-+
-+int
-+main (int argc, char **argv)
-+{
-+  error_t err;
-+  mach_port_t bootstrap;
-+  struct trivfs_control *fsys;
-+  struct port_class *notification_class;
-+
-+  /* We use the same argp for options available at startup
-+     as for options we'll accept in an fsys_set_options RPC.  */
-+  argp_parse (&hello_argp, argc, argv, 0, 0, 0);
-+
-+  err = get_privileged_ports (&host_priv, NULL);
-+  if (err)
-+    error (1, err, "Must be started as root");
-+
-+  task_get_bootstrap_port (mach_task_self (), &bootstrap);
-+  if (bootstrap == MACH_PORT_NULL)
-+    error (1, 0, "Must be started as a translator");
-+
-+  /* Reply to our parent */
-+  err = trivfs_startup (bootstrap, 0, 0, 0, 0, 0, &fsys);
-+  if (err)
-+    error (3, err, "trivfs_startup");
-+
-+  err = mach_port_deallocate (mach_task_self (), bootstrap);
-+  assert_perror (err);
-+
-+  notification_class = ports_create_class (NULL, NULL);
-+  if (! notification_class)
-+    error (1, errno, "ports_create_class");
-+
-+  err = ports_create_port (notification_class, fsys->pi.bucket, 0,
-+			   &notification);
-+  if (err)
-+    error (1, err, "ports_create_port");
-+
-+  /* Launch. */
-+  ports_manage_port_operations_one_thread (fsys->pi.bucket, demuxer, 0);
-+
-+  return 0;
-+}
-+
-+/* This structure keeps track of each notified task.  */
-+struct ntfy_task
-+  {
-+    mach_port_t notify_port;
-+    struct ntfy_task *next;
-+    char *name;
-+  };
-+
-+/* This structure keeps track of each registered essential task.  */
-+struct ess_task
-+  {
-+    struct ess_task *next;
-+    task_t task_port;
-+    char *name;
-+  };
-+
-+/* These are linked lists of all of the registered items.  */
-+static struct ess_task *ess_tasks;
-+static struct ntfy_task *ntfy_tasks;
-+
-+/** System shutdown **/
-+
-+/* Reboot the microkernel.  */
-+void
-+reboot_mach (int flags)
-+{
-+  error_t err;
-+  printf ("%s: %sing Mach (flags %#x)...\n",
-+	  program_invocation_short_name, BOOT (flags), flags);
-+  fflush (stdout);
-+  sleep (5);
-+  while ((err = host_reboot (host_priv, flags)))
-+    error (0, err, "reboot");
-+  for (;;);
-+}
-+
-+/* Reboot the microkernel, specifying that this is a crash. */
-+void
-+crash_mach (void)
-+{
-+  reboot_mach (crash_flags);
-+}
-+
-+/* Notify all tasks that have requested shutdown notifications */
-+void
-+notify_shutdown (const char *msg)
-+{
-+  struct ntfy_task *n;
-+
-+  for (n = ntfy_tasks; n != NULL; n = n->next)
-+    {
-+      error_t err;
-+      printf ("%s: notifying %s of %s...",
-+	      program_invocation_short_name, n->name, msg);
-+      fflush (stdout);
-+      err = startup_dosync (n->notify_port, 60000); /* 1 minute to reply */
-+      if (err == MACH_SEND_INVALID_DEST)
-+	puts ("(no longer present)");
-+      else if (err)
-+	puts (strerror (err));
-+      else
-+	puts ("done");
-+      fflush (stdout);
-+    }
-+}
-+
-+/* Reboot the Hurd. */
-+void
-+reboot_system (int flags)
-+{
-+  notify_shutdown (BOOT (flags));
-+  reboot_mach (flags);
-+}
-+
-+/* Reboot the Hurd, specifying that this is a crash. */
-+void
-+crash_system (void)
-+{
-+  reboot_system (crash_flags);
-+}
-+
-+/* Request a dead-name notification sent to our port.  */
-+static error_t
-+request_dead_name (mach_port_t name)
-+{
-+  error_t err;
-+  mach_port_t prev;
-+  err = mach_port_request_notification (mach_task_self (), name,
-+					MACH_NOTIFY_DEAD_NAME, 1,
-+					notification->port_right,
-+					MACH_MSG_TYPE_MAKE_SEND_ONCE, &prev);
-+  if (prev != MACH_PORT_NULL)
-+    mach_port_deallocate (mach_task_self (), prev);
-+  return err;
-+}
-+
-+/* Record an essential task in the list.  */
-+static error_t
-+record_essential_task (const char *name, task_t task)
-+{
-+  error_t err;
-+  struct ess_task *et;
-+  /* Record this task as essential.  */
-+  et = malloc (sizeof (struct ess_task));
-+  if (et == NULL)
-+    return ENOMEM;
-+  et->task_port = task;
-+  et->name = strdup (name);
-+  if (et->name == NULL)
-+    {
-+      free (et);
-+      return ENOMEM;
-+    }
-+  et->next = ess_tasks;
-+  ess_tasks = et;
-+
-+  /* Dead-name notification on the task port will tell us when it dies.	 */
-+  err = request_dead_name (task);
-+  if (err)
-+    return err;
-+
-+  return 0;
-+}
-+
-+kern_return_t
-+S_startup_essential_task (mach_port_t server,
-+			  mach_port_t reply,
-+			  mach_msg_type_name_t replytype,
-+			  task_t task,
-+			  mach_port_t excpt,
-+			  char *name,
-+			  mach_port_t credential)
-+{
-+  error_t err;
-+  if (credential != host_priv)
-+    return EPERM;
-+
-+  err = mach_port_deallocate (mach_task_self (), credential);
-+  assert_perror (err);
-+
-+  err = record_essential_task (name, task);
-+  if (err)
-+    return err;
-+
-+  return 0;
-+}
-+
-+kern_return_t
-+S_startup_request_notification (mach_port_t server,
-+				mach_port_t notify,
-+				char *name)
-+{
-+  error_t err;
-+  struct ntfy_task *nt;
-+
-+  err = request_dead_name (notify);
-+  if (err)
-+    return err;
-+
-+  /* Note that the ntfy_tasks list is kept in inverse order of the
-+     calls; this is important.	We need later notification requests
-+     to get executed first.  */
-+  nt = malloc (sizeof (struct ntfy_task));
-+  nt->notify_port = notify;
-+  nt->next = ntfy_tasks;
-+  nt->name = strdup (name);
-+  ntfy_tasks = nt;
-+  return 0;
-+}
-+
-+kern_return_t
-+S_startup_procinit (startup_t bootstrap,
-+		    mach_port_t reply,
-+		    mach_msg_type_name_t replyPoly,
-+		    process_t procserver,
-+		    mach_port_t *startuptask,
-+		    auth_t *auth,
-+		    mach_port_t *hostpriv,
-+		    mach_msg_type_name_t *hostprivPoly,
-+		    mach_port_t *devmaster,
-+		    mach_msg_type_name_t *devmasterPoly)
-+{
-+  return EOPNOTSUPP;
-+}
-+
-+kern_return_t
-+S_startup_authinit (startup_t bootstrap,
-+		    mach_port_t reply,
-+		    mach_msg_type_name_t replyPoly,
-+		    mach_port_t auth,
-+		    mach_port_t *proc,
-+		    mach_msg_type_name_t *procPoly)
-+{
-+  return EOPNOTSUPP;
-+}
-+
-+error_t
-+ports_do_mach_notify_dead_name (struct port_info *pi,
-+				mach_port_t dead_name)
-+{
-+  error_t err;
-+  struct ntfy_task *nt, *pnt;
-+  struct ess_task *et;
-+
-+  if (!pi)
-+    return EOPNOTSUPP;
-+
-+  ports_dead_name (pi, dead_name);
-+
-+  /* Drop gratuitous extra reference that the notification creates. */
-+  err = mach_port_deallocate (mach_task_self (), dead_name);
-+  assert_perror (err);
-+
-+  if (pi != notification)
-+    return 0;
-+
-+  for (et = ess_tasks; et != NULL; et = et->next)
-+    if (et->task_port == dead_name)
-+      /* An essential task has died.  */
-+      {
-+	error (0, 0, "Crashing system; essential task %s died", et->name);
-+	crash_system ();
-+      }
-+
-+  for (nt = ntfy_tasks, pnt = NULL; nt != NULL; pnt = nt, nt = nt->next)
-+    if (nt->notify_port == dead_name)
-+      {
-+	/* Someone who wanted to be notified is gone.  */
-+	err = mach_port_deallocate (mach_task_self (), dead_name);
-+	assert_perror (err);
-+	if (pnt != NULL)
-+	  pnt->next = nt->next;
-+	else
-+	  ntfy_tasks = nt->next;
-+	free (nt);
-+
-+	return 0;
-+      }
-+
-+  return 0;
-+}
-+
-+kern_return_t
-+S_startup_reboot (mach_port_t server,
-+		  mach_port_t refpt,
-+		  int code)
-+{
-+  if (refpt != host_priv)
-+    return EPERM;
-+
-+  reboot_system (code);
-+  for (;;);
-+}
--- 
-2.1.4
-
diff --git a/debian/patches/0004-XXX-bootshell.patch b/debian/patches/0004-XXX-bootshell.patch
deleted file mode 100644
index 79d17ebe..00000000
--- a/debian/patches/0004-XXX-bootshell.patch
+++ /dev/null
@@ -1,10588 +0,0 @@
-From 1e208f5dfa39821625450767c266209044cc4f86 Mon Sep 17 00:00:00 2001
-From: Justus Winter <4winter@informatik.uni-hamburg.de>
-Date: Tue, 23 Dec 2014 15:03:44 +0100
-Subject: [PATCH hurd 4/5] XXX bootshell
-
-XXX hack in toplevel Makefile.
----
- Makefile                        |    1 +
- bootshell/COPYING.tinyscheme    |   31 +
- bootshell/Makefile              |   67 +
- bootshell/Manual.txt            |  452 ++++
- bootshell/MiniSCHEMETribute.txt |   88 +
- bootshell/boot.scm              |  251 ++
- bootshell/bootshell.h           |   33 +
- bootshell/exceptions.c          |   72 +
- bootshell/exec-startup.c        |  162 ++
- bootshell/ffi.c                 | 1051 ++++++++
- bootshell/ffi.h                 |  130 +
- bootshell/fs.c                  |   91 +
- bootshell/fsys.c                |   84 +
- bootshell/hack.txt              |  244 ++
- bootshell/init.scm              |  716 ++++++
- bootshell/main.c                |  248 ++
- bootshell/mig-decls.h           |    3 +
- bootshell/mig-mutate.h          |   27 +
- bootshell/opdefines.h           |  195 ++
- bootshell/runsystem.scm         |  196 ++
- bootshell/scheme-config.h       |   12 +
- bootshell/scheme-private.h      |  210 ++
- bootshell/scheme.c              | 5075 +++++++++++++++++++++++++++++++++++++++
- bootshell/scheme.h              |  255 ++
- bootshell/startup.c             |  489 ++++
- bootshell/startup.h             |   12 +
- bootshell/utils.c               |  118 +
- config.make.in                  |    4 +
- configure.ac                    |   15 +
- 29 files changed, 10332 insertions(+)
- create mode 100644 bootshell/COPYING.tinyscheme
- create mode 100644 bootshell/Makefile
- create mode 100644 bootshell/Manual.txt
- create mode 100644 bootshell/MiniSCHEMETribute.txt
- create mode 100644 bootshell/boot.scm
- create mode 100644 bootshell/bootshell.h
- create mode 100644 bootshell/exceptions.c
- create mode 100644 bootshell/exec-startup.c
- create mode 100644 bootshell/ffi.c
- create mode 100644 bootshell/ffi.h
- create mode 100644 bootshell/fs.c
- create mode 100644 bootshell/fsys.c
- create mode 100644 bootshell/hack.txt
- create mode 100644 bootshell/init.scm
- create mode 100644 bootshell/main.c
- create mode 100644 bootshell/mig-decls.h
- create mode 100644 bootshell/mig-mutate.h
- create mode 100644 bootshell/opdefines.h
- create mode 100644 bootshell/runsystem.scm
- create mode 100644 bootshell/scheme-config.h
- create mode 100644 bootshell/scheme-private.h
- create mode 100644 bootshell/scheme.c
- create mode 100644 bootshell/scheme.h
- create mode 100644 bootshell/startup.c
- create mode 100644 bootshell/startup.h
- create mode 100644 bootshell/utils.c
-
-diff --git a/Makefile b/Makefile
-index 3178740..3a2c2ed 100644
---- a/Makefile
-+++ b/Makefile
-@@ -32,6 +32,7 @@ lib-subdirs = libshouldbeinlibc libihash libiohelp libports libthreads \
- 
- # Hurd programs
- prog-subdirs = auth proc exec term \
-+	       bootshell \
- 	       ext2fs isofs tmpfs fatfs \
- 	       storeio pflocal pfinet defpager mach-defpager \
- 	       login daemons boot console \
-diff --git a/bootshell/COPYING.tinyscheme b/bootshell/COPYING.tinyscheme
-new file mode 100644
-index 0000000..a6c49a2
---- /dev/null
-+++ b/bootshell/COPYING.tinyscheme
-@@ -0,0 +1,31 @@
-+                         LICENSE TERMS
-+
-+Copyright (c) 2000, Dimitrios Souflis
-+All rights reserved.
-+
-+Redistribution and use in source and binary forms, with or without
-+modification, are permitted provided that the following conditions are
-+met:
-+
-+Redistributions of source code must retain the above copyright notice,
-+this list of conditions and the following disclaimer.
-+
-+Redistributions in binary form must reproduce the above copyright
-+notice, this list of conditions and the following disclaimer in the
-+documentation and/or other materials provided with the distribution.
-+
-+Neither the name of Dimitrios Souflis nor the names of the
-+contributors may be used to endorse or promote products derived from
-+this software without specific prior written permission.
-+
-+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 
-+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR 
-+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 
-+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 
-+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 
-+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
-+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 
-+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 
-+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-diff --git a/bootshell/Makefile b/bootshell/Makefile
-new file mode 100644
-index 0000000..2f7cb85
---- /dev/null
-+++ b/bootshell/Makefile
-@@ -0,0 +1,67 @@
-+# Makefile for bootshell subdirectory of hurd sources
-+#
-+#   Copyright (C) 1999, 2000, 2002, 2007, 2010, 2012 Free Software Foundation,
-+#   Inc.
-+#
-+#   This file is part of the GNU Hurd.
-+#
-+#   The GNU Hurd 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 2, or (at
-+#   your option) any later version.
-+#
-+#   The GNU Hurd 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, write to the Free Software
-+#   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-+
-+dir	:= bootshell
-+makemode:= server
-+target	:= bootshell
-+
-+SCRIPTS := \
-+	init.scm \
-+	boot.scm \
-+	runsystem.scm \
-+
-+SRCS	:= \
-+	scheme.c \
-+	main.c \
-+	exceptions.c \
-+	fs.c \
-+	fsys.c \
-+	exec-startup.c \
-+	startup.c \
-+	utils.c \
-+	ffi.c \
-+
-+SERVER_PROTOCOLS := exc exec_startup fs fsys startup
-+USER_PROTOCOLS := startup startup_reply
-+
-+MIGSTUBS:= $(foreach p,$(SERVER_PROTOCOLS),$(p)Server.o) \
-+	   $(foreach p,$(USER_PROTOCOLS),$(p)User.o)
-+OBJS 	:= $(SRCS:.c=.o) $(SCRIPTS:.scm=.o) $(MIGSTUBS)
-+
-+HURDLIBS:= shouldbeinlibc
-+# XXX why doesn't $(libreadline_LIBS) work ???
-+OTHERLIBS:= $(libreadline_LIBS) -lreadline -lhistory -lncurses -ltinfo -lpthread
-+CFLAGS += -imacros scheme-config.h
-+LDFLAGS += -static
-+MIGSFLAGS := -imacros mig-mutate.h
-+
-+%.o: %.scm
-+	cat <$< >.$@
-+	$(LD) -r --format=binary .$@ -o $@
-+	rm .$@
-+
-+NOWARN := conversion sign-conversion switch unused-function
-+CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS))
-+
-+# XXX
-+CFLAGS += -Wno-sign-conversion
-+
-+include ../Makeconf
-diff --git a/bootshell/Manual.txt b/bootshell/Manual.txt
-new file mode 100644
-index 0000000..bf0e8ea
---- /dev/null
-+++ b/bootshell/Manual.txt
-@@ -0,0 +1,452 @@
-+
-+
-+                       TinySCHEME Version 1.41
-+
-+                    "Safe if used as prescribed"
-+                    -- Philip K. Dick, "Ubik"
-+
-+This software is open source, covered by a BSD-style license.
-+Please read accompanying file COPYING.
-+-------------------------------------------------------------------------------
-+
-+     This Scheme interpreter is based on MiniSCHEME version 0.85k4
-+     (see miniscm.tar.gz in the Scheme Repository)
-+     Original credits in file MiniSCHEMETribute.txt.
-+
-+     D. Souflis (dsouflis@acm.org)
-+
-+-------------------------------------------------------------------------------
-+     What is TinyScheme?
-+     -------------------
-+
-+     TinyScheme is a lightweight Scheme interpreter that implements as large
-+     a subset of R5RS as was possible without getting very large and
-+     complicated. It is meant to be used as an embedded scripting interpreter
-+     for other programs. As such, it does not offer IDEs or extensive toolkits
-+     although it does sport a small top-level loop, included conditionally.
-+     A lot of functionality in TinyScheme is included conditionally, to allow
-+     developers freedom in balancing features and footprint.
-+
-+     As an embedded interpreter, it allows multiple interpreter states to
-+     coexist in the same program, without any interference between them.
-+     Programmatically, foreign functions in C can be added and values
-+     can be defined in the Scheme environment. Being a quite small program,
-+     it is easy to comprehend, get to grips with, and use.
-+
-+     Known bugs
-+     ----------
-+
-+     TinyScheme is known to misbehave when memory is exhausted.
-+
-+
-+     Things that keep missing, or that need fixing
-+     ---------------------------------------------
-+
-+     There are no hygienic macros. No rational or
-+     complex numbers. No unwind-protect and call-with-values.
-+
-+     Maybe (a subset of) SLIB will work with TinySCHEME...
-+
-+     Decent debugging facilities are missing. Only tracing is supported
-+     natively.
-+
-+
-+     Scheme Reference
-+     ----------------
-+
-+     If something seems to be missing, please refer to the code and
-+     "init.scm", since some are library functions.  Refer to the MiniSCHEME
-+     readme as a last resort.
-+
-+          Environments
-+     (interaction-environment)
-+     See R5RS. In TinySCHEME, immutable list of association lists.
-+
-+     (current-environment)
-+     The environment in effect at the time of the call. An example of its
-+     use and its utility can be found in the sample code that implements
-+     packages in "init.scm":
-+
-+          (macro (package form)
-+               `(apply (lambda ()
-+                         ,@(cdr form)
-+                         (current-environment))))
-+
-+     The environment containing the (local) definitions inside the closure
-+     is returned as an immutable value.
-+
-+     (defined? <symbol>) (defined? <symbol> <environment>)
-+     Checks whether the given symbol is defined in the current (or given)
-+     environment.
-+
-+          Symbols
-+     (gensym)
-+     Returns a new interned symbol each time. Will probably move to the
-+     library when string->symbol is implemented.
-+
-+          Directives
-+     (gc)
-+     Performs garbage collection immediatelly.
-+
-+     (gcverbose) (gcverbose <bool>)
-+     The argument (defaulting to #t) controls whether GC produces
-+     visible outcome.
-+
-+     (quit) (quit <num>)
-+     Stops the interpreter and sets the 'retcode' internal field (defaults
-+     to 0). When standalone, 'retcode' is returned as exit code to the OS.
-+
-+     (tracing <num>)
-+     1, turns on tracing. 0 turns it off. (Only when USE_TRACING is 1).
-+
-+          Mathematical functions
-+     Since rationals and complexes are absent, the respective functions
-+     are also missing.
-+     Supported: exp, log, sin, cos, tan, asin, acos, atan, floor, ceiling,
-+     trunc, round and also sqrt and expt when USE_MATH=1.
-+     Number-theoretical quotient, remainder and modulo, gcd, lcm.
-+     Library: exact?, inexact?, odd?, even?, zero?, positive?, negative?,
-+     exact->inexact. inexact->exact is a core function.
-+
-+          Type predicates
-+     boolean?,eof-object?,symbol?,number?,string?,integer?,real?,list?,null?,
-+     char?,port?,input-port?,output-port?,procedure?,pair?,environment?',
-+     vector?. Also closure?, macro?.
-+
-+          Types
-+     Types supported:
-+
-+          Numbers (integers and reals)
-+          Symbols
-+          Pairs
-+          Strings
-+          Characters
-+          Ports
-+          Eof object
-+          Environments
-+          Vectors
-+
-+          Literals
-+     String literals can contain escaped quotes \" as usual, but also
-+     \n, \r, \t, \xDD (hex representations) and \DDD (octal representations).
-+     Note also that it is possible to include literal newlines in string
-+     literals, e.g.
-+
-+          (define s "String with newline here
-+          and here
-+          that can function like a HERE-string")
-+
-+     Character literals contain #\space and #\newline and are supplemented
-+     with #\return and #\tab, with obvious meanings. Hex character
-+     representations are allowed (e.g. #\x20 is #\space).
-+     When USE_ASCII_NAMES is defined, various control characters can be
-+     referred to by their ASCII name.
-+     0	     #\nul	       17       #\dc1
-+     1	     #\soh             18       #\dc2
-+     2	     #\stx             19       #\dc3
-+     3	     #\etx             20       #\dc4
-+     4	     #\eot             21       #\nak
-+     5	     #\enq             22       #\syn
-+     6	     #\ack             23       #\etv
-+     7	     #\bel             24       #\can
-+     8	     #\bs              25       #\em
-+     9	     #\ht              26       #\sub
-+     10	     #\lf              27       #\esc
-+     11	     #\vt              28       #\fs
-+     12	     #\ff              29       #\gs
-+     13	     #\cr              30       #\rs
-+     14	     #\so              31       #\us
-+     15	     #\si
-+     16	     #\dle             127      #\del 		
-+
-+     Numeric literals support #x #o #b and #d. Flonums are currently read only
-+     in decimal notation. Full grammar will be supported soon.
-+
-+          Quote, quasiquote etc.
-+     As usual.
-+
-+          Immutable values
-+     Immutable pairs cannot be modified by set-car! and set-cdr!.
-+     Immutable strings cannot be modified via string-set!
-+
-+          I/O
-+     As per R5RS, plus String Ports (see below).
-+     current-input-port, current-output-port,
-+     close-input-port, close-output-port, input-port?, output-port?,
-+     open-input-file, open-output-file.
-+     read, write, display, newline, write-char, read-char, peek-char.
-+     char-ready? returns #t only for string ports, because there is no
-+     portable way in stdio to determine if a character is available.
-+     Also open-input-output-file, set-input-port, set-output-port (not R5RS)
-+     Library: call-with-input-file, call-with-output-file,
-+     with-input-from-file, with-output-from-file and
-+     with-input-output-from-to-files, close-port and input-output-port?
-+     (not R5RS).
-+     String Ports: open-input-string, open-output-string, get-output-string,
-+     open-input-output-string. Strings can be used with I/O routines.
-+
-+          Vectors
-+     make-vector, vector, vector-length, vector-ref, vector-set!, list->vector,
-+     vector-fill!, vector->list, vector-equal? (auxiliary function, not R5RS)
-+
-+          Strings
-+     string, make-string, list->string, string-length, string-ref, string-set!,
-+     substring, string->list, string-fill!, string-append, string-copy.
-+     string=?, string<?, string>?, string>?, string<=?, string>=?.
-+     (No string-ci*? yet). string->number, number->string. Also atom->string,
-+     string->atom (not R5RS).
-+
-+          Symbols
-+     symbol->string, string->symbol
-+
-+          Characters
-+     integer->char, char->integer.
-+     char=?, char<?, char>?, char<=?, char>=?.
-+     (No char-ci*?)
-+
-+          Pairs & Lists
-+     cons, car, cdr, list, length, map, for-each, foldr, list-tail,
-+     list-ref, last-pair, reverse, append.
-+     Also member, memq, memv, based on generic-member, assoc, assq, assv
-+     based on generic-assoc.
-+
-+          Streams
-+     head, tail, cons-stream
-+
-+          Control features
-+     Apart from procedure?, also macro? and closure?
-+     map, for-each, force, delay, call-with-current-continuation (or call/cc),
-+     eval, apply. 'Forcing' a value that is not a promise produces the value.
-+     There is no call-with-values, values, nor dynamic-wind. Dynamic-wind in
-+     the presence of continuations would require support from the abstract
-+     machine itself.
-+
-+          Property lists
-+     TinyScheme inherited from MiniScheme property lists for symbols.
-+     put, get.
-+
-+          Dynamically-loaded extensions
-+     (load-extension <filename without extension>)
-+     Loads a DLL declaring foreign procedures. On Unix/Linux, one can make use
-+     of the ld.so.conf file or the LD_RUN_PATH system variable in order to place
-+     the library in a directory other than the current one. Please refer to the
-+     appropriate 'man' page.
-+
-+          Esoteric procedures
-+     (oblist)
-+     Returns the oblist, an immutable list of all the symbols.
-+
-+     (macro-expand <form>)
-+     Returns the expanded form of the macro call denoted by the argument
-+
-+     (define-with-return (<procname> <args>...) <body>)
-+     Like plain 'define', but makes the continuation available as 'return'
-+     inside the procedure. Handy for imperative programs.
-+
-+     (new-segment <num>)
-+     Allocates more memory segments.
-+
-+     defined?
-+     See "Environments"
-+
-+     (get-closure-code <closure>)
-+     Gets the code as scheme data.
-+
-+     (make-closure <code> <environment>)
-+     Makes a new closure in the given environment.
-+
-+          Obsolete procedures
-+     (print-width <object>)
-+
-+     Programmer's Reference
-+     ----------------------
-+
-+     The interpreter state is initialized with "scheme_init".
-+     Custom memory allocation routines can be installed with an alternate
-+     initialization function: "scheme_init_custom_alloc".
-+     Files can be loaded with "scheme_load_file". Strings containing Scheme
-+     code can be loaded with "scheme_load_string". It is a good idea to
-+     "scheme_load" init.scm before anything else.
-+
-+     External data for keeping external state (of use to foreign functions)
-+     can be installed with "scheme_set_external_data".
-+     Foreign functions are installed with "assign_foreign". Additional
-+     definitions can be added to the interpreter state, with "scheme_define"
-+     (this is the way HTTP header data and HTML form data are passed to the
-+     Scheme script in the Altera SQL Server). If you wish to define the
-+     foreign function in a specific environment (to enhance modularity),
-+     use "assign_foreign_env".
-+
-+     The procedure "scheme_apply0" has been added with persistent scripts in
-+     mind. Persistent scripts are loaded once, and every time they are needed
-+     to produce HTTP output, appropriate data are passed through global
-+     definitions and function "main" is called to do the job. One could
-+     add easily "scheme_apply1" etc.
-+
-+     The interpreter state should be deinitialized with "scheme_deinit".
-+
-+     DLLs containing foreign functions should define a function named
-+     init_<base-name>. E.g. foo.dll should define init_foo, and bar.so
-+     should define init_bar. This function should assign_foreign any foreign
-+     function contained in the DLL.
-+
-+     The first dynamically loaded extension available for TinyScheme is
-+     a regular expression library. Although it's by no means an
-+     established standard, this library is supposed to be installed in
-+     a directory mirroring its name under the TinyScheme location.
-+
-+
-+     Foreign Functions
-+     -----------------
-+
-+     The user can add foreign functions in C. For example, a function
-+     that squares its argument:
-+
-+          pointer square(scheme *sc, pointer args) {
-+           if(args!=sc->NIL) {
-+               if(sc->isnumber(sc->pair_car(args))) {
-+                    double v=sc->rvalue(sc->pair_car(args));
-+                    return sc->mk_real(sc,v*v);
-+               }
-+           }
-+           return sc->NIL;
-+          }
-+
-+   Foreign functions are now defined as closures:
-+
-+   sc->interface->scheme_define(
-+        sc,
-+        sc->global_env,
-+        sc->interface->mk_symbol(sc,"square"),
-+        sc->interface->mk_foreign_func(sc, square));
-+
-+
-+     Foreign functions can use the external data in the "scheme" struct
-+     to implement any kind of external state.
-+
-+     External data are set with the following function:
-+          void scheme_set_external_data(scheme *sc, void *p);
-+
-+     As of v.1.17, the canonical way for a foreign function in a DLL to
-+     manipulate Scheme data is using the function pointers in sc->interface.
-+
-+     Standalone
-+     ----------
-+
-+     Usage: tinyscheme -?
-+     or:    tinyscheme [<file1> <file2> ...]
-+     followed by
-+	       -1 <file> [<arg1> <arg2> ...]
-+	       -c <Scheme commands> [<arg1> <arg2> ...]
-+     assuming that the executable is named tinyscheme.
-+
-+     Use - in the place of a filename to denote stdin.
-+     The -1 flag is meant for #! usage in shell scripts. If you specify
-+          #! /somewhere/tinyscheme -1
-+     then tinyscheme will be called to process the file. For example, the
-+     following script echoes the Scheme list of its arguments.
-+
-+	       #! /somewhere/tinyscheme -1
-+	       (display *args*)
-+
-+     The -c flag permits execution of arbitrary Scheme code.
-+
-+
-+     Error Handling
-+     --------------
-+
-+     Errors are recovered from without damage. The user can install his
-+     own handler for system errors, by defining *error-hook*. Defining
-+     to '() gives the default behavior, which is equivalent to "error".
-+     USE_ERROR_HOOK must be defined.
-+
-+     A simple exception handling mechanism can be found in "init.scm".
-+     A new syntactic form is introduced:
-+
-+          (catch <expr returned exceptionally>
-+               <expr1> <expr2> ... <exprN>)
-+
-+     "Catch" establishes a scope spanning multiple call-frames
-+     until another "catch" is encountered.
-+
-+     Exceptions are thrown with:
-+
-+          (throw "message")
-+
-+     If used outside a (catch ...), reverts to (error "message").
-+
-+     Example of use:
-+
-+          (define (foo x) (write x) (newline) (/ x 0))
-+
-+          (catch (begin (display "Error!\n") 0)
-+               (write "Before foo ... ")
-+               (foo 5)
-+               (write "After foo"))
-+
-+     The exception mechanism can be used even by system errors, by
-+
-+          (define *error-hook* throw)
-+
-+     which makes use of the error hook described above.
-+
-+     If necessary, the user can devise his own exception mechanism with
-+     tagged exceptions etc.
-+
-+
-+     Reader extensions
-+     -----------------
-+
-+     When encountering an unknown character after '#', the user-specified
-+     procedure *sharp-hook* (if any), is called to read the expression.
-+     This can be used to extend the reader to handle user-defined constants
-+     or whatever. It should be a procedure without arguments, reading from
-+     the current input port (which will be the load-port).
-+
-+
-+     Colon Qualifiers - Packages
-+     ---------------------------
-+
-+     When USE_COLON_HOOK=1:
-+     The lexer now recognizes the construction <qualifier>::<symbol> and
-+     transforms it in the following manner (T is the transformation function):
-+
-+          T(<qualifier>::<symbol>) = (*colon-hook* 'T(<symbol>) <qualifier>)
-+
-+     where <qualifier> is a symbol not containing any double-colons.
-+
-+     As the definition is recursive, qualifiers can be nested.
-+     The user can define his own *colon-hook*, to handle qualified names.
-+     By default, "init.scm" defines *colon-hook* as EVAL. Consequently,
-+     the qualifier must denote a Scheme environment, such as one returned
-+     by (interaction-environment). "Init.scm" defines a new syntantic form,
-+     PACKAGE, as a simple example. It is used like this:
-+
-+          (define toto
-+               (package
-+                    (define foo 1)
-+                    (define bar +)))
-+
-+          foo                                     ==>  Error, "foo" undefined
-+          (eval 'foo)                             ==>  Error, "foo" undefined
-+          (eval 'foo toto)                        ==>  1
-+          toto::foo                               ==>  1
-+          ((eval 'bar toto) 2 (eval 'foo toto))   ==>  3
-+          (toto::bar 2 toto::foo)                 ==>  3
-+          (eval (bar 2 foo) toto)                 ==>  3
-+
-+     If the user installs another package infrastructure, he must define
-+     a new 'package' procedure or macro to retain compatibility with supplied
-+     code.
-+
-+     Note: Older versions used ':' as a qualifier. Unfortunately, the use
-+     of ':' as a pseudo-qualifier in existing code (i.e. SLIB) essentially
-+     precludes its use as a real qualifier.
-+
-+
-+
-+
-+
-+
-+
-+
-diff --git a/bootshell/MiniSCHEMETribute.txt b/bootshell/MiniSCHEMETribute.txt
-new file mode 100644
-index 0000000..02ebd26
---- /dev/null
-+++ b/bootshell/MiniSCHEMETribute.txt
-@@ -0,0 +1,88 @@
-+     TinyScheme would not exist if it wasn't for MiniScheme. I had just
-+     written the HTTP server for Ovrimos SQL Server, and I was lamenting the
-+     lack of a scripting language. Server-side Javascript would have been the
-+     preferred solution, had there been a Javascript interpreter I could
-+     lay my hands on. But there weren't. Perl would have been another solution,
-+     but it was probably ten times bigger that the program it was supposed to
-+     be embedded in. There would also be thorny licencing issues. 
-+     
-+     So, the obvious thing to do was find a trully small interpreter. Forth
-+     was a language I had once quasi-implemented, but the difficulty of
-+     handling dynamic data and the weirdness of the language put me off. I then
-+     looked around for a LISP interpreter, the next thing I knew was easy to
-+     implement. Alas, the LeLisp I knew from my days in UPMC (Universite Pierre
-+     et Marie Curie) had given way to Common Lisp, a megalith of a language!
-+     Then my search lead me to Scheme, a language I knew was very orthogonal
-+     and clean. When I found Mini-Scheme, a single C file of some 2400 loc, I 
-+     fell in love with it! What if it lacked floating-point numbers and 
-+     strings! The rest, as they say, is history.
-+     
-+     Below  are the original credits. Don't email Akira KIDA, the address has
-+     changed.
-+     
-+     ---------- Mini-Scheme Interpreter Version 0.85 ----------
-+
-+                coded by Atsushi Moriwaki (11/5/1989)
-+
-+            E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
-+
-+               THIS SOFTWARE IS IN THE PUBLIC DOMAIN
-+               ------------------------------------
-+ This software is completely free to copy, modify and/or re-distribute.
-+ But I would appreciate it if you left my name on the code as the author.
-+
-+  This version has been modified by R.C. Secrist.
-+
-+  Mini-Scheme is now maintained by Akira KIDA.
-+
-+  This is a revised and modified version by Akira KIDA.
-+   current version is 0.85k4 (15 May 1994)
-+
-+  Please send suggestions, bug reports and/or requests to:
-+        <SDI00379@niftyserve.or.jp>
-+
-+
-+     Features compared to MiniSCHEME
-+     -------------------------------
-+
-+     All code is now reentrant. Interpreter state is held in a 'scheme'
-+     struct, and many interpreters can coexist in the same program, possibly
-+     in different threads. The user can specify user-defined memory allocation
-+     primitives. (see "Programmer's Reference")
-+
-+     The reader is more consistent.
-+
-+     Strings, characters and flonums are supported. (see "Types")
-+
-+     Files being loaded can be nested up to some depth.
-+
-+     R5RS I/O is there, plus String Ports. (see "Scheme Reference","I/O")
-+
-+     Vectors exist.
-+
-+     As a standalone application, it supports command-line arguments.
-+     (see "Standalone")
-+
-+     Running out of memory is now handled.
-+
-+     The user can add foreign functions in C. (see "Foreign Functions")
-+
-+     The code has been changed slightly, core functions have been moved
-+     to the library, behavior has been aligned with R5RS etc.
-+
-+     Support has been added for user-defined error recovery.
-+     (see "Error Handling")
-+
-+     Support has been added for modular programming.
-+     (see "Colon Qualifiers - Packages")
-+
-+     To enable this, EVAL has changed internally, and can
-+     now take two arguments, as per R5RS. Environments are supported.
-+     (see "Colon Qualifiers - Packages")
-+
-+     Promises are now evaluated once only.
-+
-+     (macro (foo form) ...) is now equivalent to (macro foo (lambda(form) ...))
-+
-+     The reader can be extended using new #-expressions
-+     (see "Reader extensions")
-diff --git a/bootshell/boot.scm b/bootshell/boot.scm
-new file mode 100644
-index 0000000..35dd4e5
---- /dev/null
-+++ b/bootshell/boot.scm
-@@ -0,0 +1,251 @@
-+;; Missing library functions.
-+(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)))))
-+
-+;; Is s1 a prefix of s2 ?
-+(define (string-prefix? s1 s2)
-+  (and (>= (string-length s2) (string-length s1))
-+       (string=? s1 (substring s2 0 (string-length s1)))))
-+
-+;; Given a list of prefixes, does s start with any of them ?
-+(define (string-prefix-any? lp s)
-+  (any (lambda (p) (string-prefix? p s)) lp))
-+
-+;; The `catch' from init.scm doesn't give the thrown value to the
-+;; handler.  As a crappy workaround, we set! `last-exception' to the
-+;; last the exception.
-+(define last-exception '())
-+(define (throw . x)
-+  (set! last-exception x)
-+  (if (more-handlers?)
-+      (apply (pop-handler))
-+      (apply error x)))
-+(define *error-hook* throw)
-+
-+;; 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
-+     ((not (= (car result) 0)) (throw (string-append
-+				       name ": " (strerror (car result)))))
-+     ((and (= (car result) 0) (pair? (cdr result))) (cadr result))
-+     ((= (car result) 0) '())
-+     (else
-+      (throw "Weird.")))))
-+
-+;; Convenience functions.
-+(define (echo . msg)
-+  (map display msg)
-+  (newline))
-+
-+(define (trace-show x)
-+  (write x)
-+  x)
-+
-+;; Semi-crappy repl using `prompt' function.
-+(define (shell p)
-+  (call/cc
-+   (lambda (exit)
-+     (let loop ((prefix ""))
-+       (let ((line (prompt (p prefix))))
-+	 (if (and (not (eof-object? line)) (eqv? (string-length line) 0))
-+	     (exit (loop prefix)))
-+	 (if (not (eof-object? line))
-+	     (let* ((next (string-append prefix line))
-+		    (c (catch (begin (echo "Parse error: " last-exception)
-+				     (loop prefix))
-+			      (read (open-input-string next)))))
-+	       (if (not (eof-object? c))
-+		   (begin
-+		     (catch (echo "Error: " last-exception)
-+			    (echo "  ===> " (eval c)))
-+		     (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 the bootshell.
-+(define (interactive-repl)
-+  (shell (lambda (p) (prompt-append-prefix "(bootshell) " p))))
-+
-+;; Default repl run by `panic'.
-+(define (emergency-shell)
-+  (shell (lambda (p) (prompt-append-prefix "(emergency-shell) " p))))
-+
-+;; Display a message and run the emergency shell.
-+(define (panic . msg)
-+  (display "\n\npanic: ")
-+  (map display msg)
-+  (newline)
-+  (emergency-shell))
-+
-+;; Mach port management.
-+(define (mach-port-valid? p) (not (or (= p MACH_PORT_NULL)
-+				      (= p MACH_PORT_DEAD))))
-+
-+(define (make-send-right receive-right)
-+  (mach-port-insert-right mach-task-self receive-right receive-right
-+			  MACH_MSG_TYPE_MAKE_SEND))
-+(define (copy-send-right send-right)
-+  (mach-port-insert-right mach-task-self send-right send-right
-+			  MACH_MSG_TYPE_COPY_SEND))
-+
-+;; Binds a send right to an identifier, much like `let'.  Deallocates
-+;; the send right once it goes out of scope.
-+(macro (letport form)
-+  (let ((result-sym (gensym)))
-+    `((lambda ((,@(caaadr form)))
-+	(let ((,result-sym
-+	       ,(if (= 1 (length (cadr form)))
-+		    `(begin ,@(cddr form))
-+		    `(letport ,(cdadr form) ,@(cddr form)))))
-+	  (if (mach-port-valid? ,(caaadr form))
-+	      (mach-port-deallocate mach-task-self ,(caaadr form)))
-+	  ,result-sym)) ,@(cdaadr form))))
-+
-+;; TinySCHEME doesn't have define-syntax :(
-+;;
-+;; (define-syntax letport
-+;;   (syntax-rules ()
-+;;     ((letport ((var expr) ...) body ...)
-+;;      ((lambda expressions
-+;;         (let ((result (apply (lambda (var ...) body ...) expressions)))
-+;;           (map (lambda (p) (mach-port-deallocate mach-task-self p))
-+;;                expressions)
-+;;           result)) expr ...))))
-+
-+;; task management
-+
-+(define (task-get-kernel-port t)
-+  (task-get-special-port t TASK_KERNEL_PORT))
-+(define (task-get-exception-port t)
-+  (task-get-special-port t TASK_EXCEPTION_PORT))
-+(define (task-get-bootstrap-port t)
-+  (task-get-special-port t TASK_BOOTSTRAP_PORT))
-+
-+(define (task-set-kernel-port t p)
-+  (task-set-special-port t TASK_KERNEL_PORT p))
-+(define (task-set-exception-port t p)
-+  (task-set-special-port t TASK_EXCEPTION_PORT p))
-+(define (task-set-bootstrap-port t p)
-+  (task-set-special-port t TASK_BOOTSTRAP_PORT p))
-+
-+;; Hurd server bootstrap.
-+
-+(define ESUCCESS 0)					;
-+
-+;; translator linkage
-+
-+(define (set-active-translator path active-control)
-+  (letport ((node (file-name-lookup path O_NOTRANS 438))) ;;=^= 0666
-+	   (file-set-translator node 0 FS_TRANS_SET 0 0 0
-+				active-control MACH_MSG_TYPE_COPY_SEND)))
-+
-+;; Wait for the predicate CONDITION to return #t, or throw 'timeout
-+;; after T microseconds.
-+(define (wait-for condition t)
-+  (if (<= t 0)
-+      (throw 'timeout)
-+      (if (not (condition))
-+	  (begin (usleep 10000)
-+		 (wait-for condition (- t 10000))))))
-+
-+;; Read a word from port P.
-+(define (read-word p)
-+  (list->string
-+   (let f ()
-+     (let ((c (peek-char p)))
-+       (cond
-+	((eof-object? c) '())
-+	((char-alphabetic? c)
-+	 (read-char p)
-+	 (cons c (f)))
-+	(else '()))))))
-+
-+;; Read everything from port P.
-+(define (read-all p)
-+  (list->string
-+   (let f ()
-+     (let ((c (peek-char p)))
-+       (cond
-+	((eof-object? c) '())
-+	(else (read-char p)
-+	 (cons c (f))))))))
-+
-+;; Shell-like functions.
-+
-+(define cd chdir)
-+(define (pwd) (echo (getcwd)))
-+(define (cat path)
-+  (display (call-with-input-file path read-all)))
-+(define (hostname)
-+  ((lambda (x) (if (string? x) x "unnamed"))
-+   (call-with-input-file "/etc/hostname" read-word)))
-+
-+(define (print-banner)
-+  (echo "
-+Welcome to bootshell, a scheme shell.  Type `(help)' for help.
-+"))
-+
-+(define (reboot-hurd)
-+  (letport ((startup (file-name-lookup "/servers/startup" 0 0)))
-+	   (startup-reboot startup host-priv RB_AUTOBOOT)))
-+
-+(define (halt-hurd)
-+  (letport ((startup (file-name-lookup "/servers/startup" 0 0)))
-+	   (startup-reboot startup host-priv RB_HALT)))
-+
-+(define (reboot-mach) (host-reboot host-priv RB_AUTOBOOT))
-+(define (halt-mach) (host-reboot host-priv RB_HALT))
-+(define (kdb-mach) (host-reboot host-priv RB_DEBUGGER))
-+
-+(define (reboot)
-+  (catch (reboot-mach)
-+	 (reboot-hurd)))
-+(define (halt)
-+  (catch (halt-mach)
-+	 (halt-hurd)))
-+
-+;; Online documentation.
-+
-+(define (help)
-+  (echo "Welcome to the Hurd boot shell.  XXX this is not up to date :(
-+
-+Functions
-+ General shell-like functions
-+  cat cd echo halt help hostname kdb mach-print panic prompt pwd
-+  reboot shell sleep {reboot,halt}-{mach,hurd}
-+" "
-+ Mach related
-+  mach-port-valid? {copy,make}-send-right task-{create,resume,terminate}
-+  task-{g,s}et-{special,kernel,exception,bootstrap}-port host-reboot
-+" "
-+ Hurd related
-+  file_name_lookup chdir getcwd startup-reboot
-+  XXX write them
-+  {s,g}etauth {s,g}etproc file_name_lookup_under file_name_path_lookup
-+" "
-+Environment:
-+ mach-task-self exception-port bootstrap-port host-priv device-master
-+ rootfs-task hello-task rootfs-control"))
-+
-+;; XXX
-+
-+(define log display)
-+
-+;; We're ready.
-+(echo version ".")
-diff --git a/bootshell/bootshell.h b/bootshell/bootshell.h
-new file mode 100644
-index 0000000..9b55958
---- /dev/null
-+++ b/bootshell/bootshell.h
-@@ -0,0 +1,33 @@
-+#ifndef _HURD_BOOTSHELL_H
-+#define _HURD_BOOTSHELL_H
-+
-+#include <mach.h>
-+
-+extern const char *argp_program_version;
-+
-+extern mach_port_t portarray_template[];
-+
-+/* We catch exceptions using this port. */
-+extern mach_port_t exception_port;
-+
-+extern mach_port_t console;
-+extern mach_port_t rootnode;
-+
-+error_t init_exception_handling (void);
-+error_t init_fs_server (void);
-+
-+void mach_print(const char *);
-+void mach_printf(const char *format, ...);
-+
-+mach_msg_return_t
-+mach_msg_server_timeout_once (boolean_t (*demux) (mach_msg_header_t *request,
-+						  mach_msg_header_t *reply),
-+			      mach_msg_size_t max_size,
-+			      mach_port_t rcv_name,
-+			      mach_msg_option_t option,
-+			      mach_msg_timeout_t timeout);
-+
-+#define TRACE	error (0, 0, "%s:%d", __FUNCTION__, __LINE__);
-+#define TR	mach_printf ("%s:%d\n", __FUNCTION__, __LINE__);
-+
-+#endif
-diff --git a/bootshell/exceptions.c b/bootshell/exceptions.c
-new file mode 100644
-index 0000000..0ad6ada
---- /dev/null
-+++ b/bootshell/exceptions.c
-@@ -0,0 +1,72 @@
-+#include <mach.h>
-+/* Mach exception handling.  */
-+#include <pthread.h>
-+// eek #include "exc_S.h"
-+
-+#include "bootshell.h"
-+
-+error_t
-+catch_exception_raise (mach_port_t e,
-+		       thread_t thread,
-+		       task_t task,
-+		       int exception, int code, int subcode)
-+{
-+  if (e != exception_port)
-+    return EOPNOTSUPP;
-+
-+  mach_printf ("catch_exception_raise (%d, %d, %d, %d, %d): ",
-+	       thread, task, exception, code, subcode);
-+
-+  if (task == mach_task_self ())
-+    mach_print ("terminating bootshell. bye.\n");
-+  else
-+    mach_printf ("terminating task %d.\n", task);
-+
-+  task_terminate (task);
-+  return 0;
-+}
-+
-+static void *
-+service_exception_requests (void *arg)
-+{
-+  extern boolean_t exc_server (mach_msg_header_t *, mach_msg_header_t *);
-+
-+  while (1)
-+    mach_msg_server (exc_server, 0, exception_port);
-+
-+  /* Not reached.  */
-+  return NULL;
-+}
-+
-+error_t
-+init_exception_handling (void)
-+{
-+  error_t err;
-+  pthread_t t;
-+
-+  err = mach_port_allocate (mach_task_self (),
-+			    MACH_PORT_RIGHT_RECEIVE,
-+			    &exception_port);
-+  if (err)
-+    return err;
-+
-+  /* Make a thread to service exception requests.  */
-+  err = pthread_create (&t, NULL, service_exception_requests, NULL);
-+  if (err)
-+    return err;
-+  pthread_detach (t);
-+
-+  err = mach_port_insert_right (mach_task_self (),
-+				exception_port,
-+				exception_port,
-+				MACH_MSG_TYPE_MAKE_SEND);
-+  if (err)
-+    return err;
-+
-+  err = task_set_exception_port (mach_task_self (), exception_port);
-+  if (err)
-+    return err;
-+
-+  return err;
-+}
-+
-diff --git a/bootshell/exec-startup.c b/bootshell/exec-startup.c
-new file mode 100644
-index 0000000..c8105c7
---- /dev/null
-+++ b/bootshell/exec-startup.c
-@@ -0,0 +1,162 @@
-+#include <assert.h>
-+#include <hurd.h>
-+#include <hurd/paths.h>
-+#include <mach.h>
-+#include <mach/message.h>
-+#include <mach/mig_support.h>
-+#include <stdio.h>
-+#include <sys/mman.h>
-+
-+// eek #include "fsys_S.h"
-+
-+#include "bootshell.h"
-+#include "ffi.h"
-+
-+/* XXX would be nice not to use a global variable, maybe with
-+   payloads.  */
-+static struct
-+{
-+  /* Filled by caller.	*/
-+  mach_port_t bootstrap_port;
-+  char *argz;
-+  size_t argz_len;
-+
-+  /* Filled by the server function.  */
-+} exec_startup_get_info_args;
-+
-+/* We look like an execserver to the execserver itself; it makes this
-+   call (as does any task) to get its state.  We can't give it all of
-+   its ports (we'll provide those with a later call to exec_init).  */
-+kern_return_t
-+S_exec_startup_get_info (mach_port_t bootstrap_port,
-+			 vm_address_t *user_entry,
-+			 vm_address_t *phdr_data,
-+			 vm_size_t *phdr_size,
-+			 vm_address_t *base_addr,
-+			 vm_size_t *stack_size,
-+			 int *flags,
-+			 char **argz,
-+			 mach_msg_type_number_t *argz_len,
-+			 char **envz,
-+			 mach_msg_type_number_t *envz_len,
-+			 mach_port_t **dtableP,
-+			 mach_msg_type_name_t *dtablepoly,
-+			 mach_msg_type_number_t *dtablelen,
-+			 mach_port_t **portarrayP,
-+			 mach_msg_type_name_t *portarraypoly,
-+			 mach_msg_type_number_t *portarraylen,
-+			 int **intarrayP,
-+			 mach_msg_type_number_t *intarraylen)
-+{
-+  error_t err;
-+  mach_port_t *portarray, *dtable;
-+
-+  if (bootstrap_port != exec_startup_get_info_args.bootstrap_port)
-+    return EOPNOTSUPP;
-+
-+  *user_entry = 0;
-+  *phdr_data = *base_addr = 0;
-+  *phdr_size = *stack_size = 0;
-+
-+  *flags = 0;
-+
-+  /* Arguments.	 */
-+  *argz_len = exec_startup_get_info_args.argz_len;
-+  if (*argz_len == 0)
-+    /* We have no args for it.	Tell it to look on its stack
-+       for the args placed there by the boot loader.  */
-+    *flags |= EXEC_STACK_ARGS;
-+  else
-+    {
-+      err = vm_allocate (mach_task_self (),
-+			 (vm_address_t *)argz, *argz_len, TRUE);
-+      if (err)
-+	return err;
-+      memcpy (*argz, exec_startup_get_info_args.argz, *argz_len);
-+    }
-+
-+  /* Environment.  */
-+  *envz = NULL;
-+  *envz_len = 0;
-+
-+  /* File descriptors.	*/
-+  if (*dtablelen < 3)
-+    *dtableP = mmap (0, 3 * sizeof (mach_port_t), PROT_READ|PROT_WRITE,
-+		     MAP_ANON, 0, 0);
-+  dtable = *dtableP;
-+  *dtablepoly = MACH_MSG_TYPE_COPY_SEND;
-+  *dtablelen = 3;
-+  dtable[0] = dtable[1] = dtable[2] = console;
-+
-+  /* Initial ports.  */
-+  if (*portarraylen < INIT_PORT_MAX)
-+    *portarrayP = mmap (0, INIT_PORT_MAX * sizeof (mach_port_t),
-+			PROT_READ|PROT_WRITE, MAP_ANON, 0, 0);
-+  portarray = *portarrayP;
-+  *portarraylen = INIT_PORT_MAX;
-+  memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray);
-+  portarray[INIT_PORT_BOOTSTRAP] = bootstrap_port; /* use the same port */
-+  *portarraypoly = MACH_MSG_TYPE_COPY_SEND;
-+
-+  /* Initial ints.  */
-+  *intarrayP = NULL;
-+  *intarraylen = 0;
-+
-+  return 0;
-+}
-+
-+boolean_t
-+exec_startup_get_info_demuxer (mach_msg_header_t *request,
-+			       mach_msg_header_t *reply)
-+{
-+  extern boolean_t exec_startup_server (mach_msg_header_t *,
-+					mach_msg_header_t *);
-+  if (request->msgh_id != 30500) /* XXX hardcoded msgh_id */
-+    {
-+      /* Return MIG_BAD_ID.  */
-+      mig_reply_setup (request, reply);
-+      return FALSE;
-+    }
-+  return exec_startup_server (request, reply);
-+}
-+
-+error_t
-+service_exec_startup_request (mach_port_t bootstrap,
-+			      char *argz,
-+			      size_t argz_len,
-+			      mach_msg_timeout_t timeout)
-+{
-+  error_t err;
-+
-+  if (! MACH_PORT_VALID (bootstrap))
-+    return EINVAL;
-+
-+  exec_startup_get_info_args.bootstrap_port = bootstrap;
-+  exec_startup_get_info_args.argz = argz;
-+  exec_startup_get_info_args.argz_len = argz_len;
-+
-+  err = mach_msg_server_timeout_once (exec_startup_get_info_demuxer,
-+				      0, bootstrap,
-+				      MACH_RCV_TIMEOUT | MACH_SEND_TIMEOUT,
-+				      timeout);
-+  if (err != MACH_MSG_SUCCESS)
-+    return err;
-+
-+  return 0;
-+}
-+
-+pointer
-+do_handle_exec_startup (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("handle-exec-startup");
-+  SC_ARG (sc, mach_port_t, bootstrap, number, args);
-+  SC_ARG (sc, pointer, arguments, list, args);
-+  SC_ARG (sc, mach_msg_timeout_t, timeout, number, args);
-+  SC_ARGS_DONE (sc);
-+  char *argz = NULL;
-+  size_t argz_len = 0;
-+  ffi_list2argz (sc, &argz, &argz_len, arguments);
-+  err = service_exec_startup_request (bootstrap, argz, argz_len, timeout);
-+  free (argz);
-+  SC_RETURN (sc);
-+}
-diff --git a/bootshell/ffi.c b/bootshell/ffi.c
-new file mode 100644
-index 0000000..b2c1afa
---- /dev/null
-+++ b/bootshell/ffi.c
-@@ -0,0 +1,1051 @@
-+#include <argz.h>
-+#include <assert.h>
-+#include <ctype.h>
-+#include <device/device.h>
-+#include <errno.h>
-+#include <error.h>
-+#include <fcntl.h>
-+#include <hurd.h>
-+#include <hurd/fsys.h>
-+#include <mach.h>
-+#include <mach/gnumach.h>
-+#include <sys/reboot.h>
-+#include <sys/mman.h>
-+#include <string.h>
-+#include <unistd.h>
-+
-+#if HAVE_LIBREADLINE
-+#include <readline/readline.h>
-+#include <readline/history.h>
-+#endif
-+
-+#include "bootshell.h"
-+#include "ffi.h"
-+
-+#include "startup.h"
-+
-+static mach_port_t
-+copy_send_right (mach_port_t right)
-+{
-+  error_t err;
-+  if (! MACH_PORT_VALID (right))
-+    return right;
-+
-+  err = mach_port_insert_right (mach_task_self (),
-+				right,
-+				right,
-+				MACH_MSG_TYPE_COPY_SEND);
-+  if (err)
-+    {
-+      error (0, err, "mach_port_insert_right");
-+      return MACH_PORT_NULL;
-+    }
-+
-+  return right;
-+}
-+
-+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;
-+  free (line);
-+
-+#if HAVE_LIBREADLINE
-+  if (use_libreadline)
-+    {
-+      line = readline (prompt);
-+      if (line && *line)
-+        add_history (line);
-+    }
-+  else
-+#endif
-+    {
-+      size_t max_size = 0xff;
-+      printf ("%s", prompt);
-+      fflush (stdout);
-+      line = malloc (max_size);
-+      if (line != NULL)
-+        fgets (line, max_size, stdin);
-+    }
-+
-+  /* Strip trailing whitespace.  */
-+  if (line && strlen (line) > 0)
-+    for (char *p = &line[strlen (line) - 1]; isspace (*p); p--)
-+      *p = 0;
-+
-+  return line;
-+}
-+
-+pointer
-+do_enable_readline (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("enable-readline");
-+  SC_ARGS_DONE (sc);
-+  use_libreadline = 1;
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_prompt (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("prompt");
-+  SC_ARG (sc, char *, prompt, string, args);
-+  SC_ARGS_DONE (sc);
-+  const char *line = rl_gets (prompt);
-+  ffi_update (sc);
-+  if (! line)
-+    SC_RETURN_POINTER (sc, sc->EOF_OBJ);
-+
-+  SC_RETURN_STRING (sc, line);
-+}
-+
-+#define is_false(p)	 ((p) == sc->F)
-+
-+pointer
-+do_mach_print (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("mach_print");
-+  int dirty = 0;
-+  while (args && is_string (pair_car (args)))
-+    {
-+      const char *v = string_value (pair_car (args));
-+      if (dirty)
-+	mach_print (" ");
-+      mach_print (v);
-+      dirty = 1;
-+      args = pair_cdr (args);
-+    }
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_host_reboot (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("host-reboot");
-+  SC_ARG (sc, mach_port_t, host_priv, number, args);
-+  SC_ARG (sc, int, flags, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = host_reboot (host_priv, flags);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_task_create (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("task-create");
-+  SC_ARG (sc, task_t, parent, number, args);
-+  SC_ARG (sc, boolean_t, inherit_memory, number, args);
-+  SC_ARGS_DONE (sc);
-+  task_t task;
-+  err = task_create (parent, inherit_memory, &task);
-+  SC_RETURN_INT (sc, task);
-+}
-+
-+pointer
-+do_task_resume (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("task-resume");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = task_resume (task);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_task_terminate (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("task-terminate");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = task_terminate (task);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_sleep (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("sleep");
-+  SC_ARG (sc, unsigned int, seconds, number, args);
-+  SC_ARGS_DONE (sc);
-+  sleep (seconds);
-+  ffi_update (sc);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_usleep (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("usleep");
-+  SC_ARG (sc, useconds_t, microseconds, number, args);
-+  SC_ARGS_DONE (sc);
-+  usleep (microseconds);
-+  ffi_update (sc);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_file_name_lookup (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("file-name-lookup");
-+  SC_ARG (sc, char *, name, string, args);
-+  SC_ARG (sc, int, flags, number, args);
-+  SC_ARG (sc, mode_t, mode, number, args);
-+  SC_ARGS_DONE (sc);
-+  file_t file = file_name_lookup (name, flags, mode);
-+  if (! MACH_PORT_VALID (file))
-+    SC_RETURN_ERR (sc, errno);
-+  SC_RETURN_INT (sc, file);
-+}
-+
-+pointer
-+do_chdir (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("chdir");
-+  SC_ARG (sc, char *, name, string, args);
-+  SC_ARGS_DONE (sc);
-+  if (chdir (name))
-+    SC_RETURN_ERR (sc, errno);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_strerror (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("strerror");
-+  SC_ARG (sc, int, error, number, args);
-+  SC_ARGS_DONE (sc);
-+  char *s, buf[128];
-+  s = strerror_r (error, buf, sizeof buf);
-+  SC_RETURN_STRING (sc, s);
-+}
-+
-+pointer
-+do_getproc (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("getproc");
-+  SC_ARGS_DONE (sc);
-+  SC_RETURN_INT (sc, getproc ());
-+}
-+
-+pointer
-+do_getcwd (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("getcwd");
-+  SC_ARGS_DONE (sc);
-+  SC_RETURN_STRING (sc, get_current_dir_name ());
-+}
-+
-+pointer
-+do_mach_port_allocate (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("mach-port-allocate");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, mach_port_t, right, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t name;
-+  err = mach_port_allocate (task, right, &name);
-+  SC_RETURN_INT (sc, name);
-+}
-+
-+pointer
-+do_mach_port_deallocate (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("mach-port-deallocate");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, mach_port_t, right, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = mach_port_deallocate (task, right);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_mach_port_destroy (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("mach-port-destroy");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, mach_port_t, right, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = mach_port_destroy (task, right);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_mach_port_insert_right (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("mach-port-insert-right");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, mach_port_t, name, number, args);
-+  SC_ARG (sc, mach_port_t, right, number, args);
-+  SC_ARG (sc, mach_msg_type_name_t, right_type, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = mach_port_insert_right (task, name, right, right_type);
-+  SC_RETURN_INT (sc, right);
-+}
-+
-+pointer
-+do_task_get_special_port (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("task-get-special-port");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, int, which, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t special_port;
-+  err = task_get_special_port (task, which, &special_port);
-+  SC_RETURN_INT (sc, special_port);
-+}
-+
-+pointer
-+do_task_set_special_port (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("task-set-special-port");
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, int, which, number, args);
-+  SC_ARG (sc, mach_port_t, special_port, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = task_set_special_port (task, which, special_port);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_device_open (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("device-open");
-+  SC_ARG (sc, mach_port_t, master, number, args);
-+  SC_ARG (sc, int, flags, number, args);
-+  SC_ARG (sc, char *, name, string, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t device;
-+  err = device_open (master, flags, name, &device);
-+  SC_RETURN_INT (sc, device);
-+}
-+
-+/* Hurd functions.  */
-+pointer
-+do_handle_fsys_startup (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("handle-fsys-startup");
-+  SC_ARG (sc, mach_port_t, bootstrap, number, args);
-+  SC_ARG (sc, mach_port_t, realnode, number, args);
-+  SC_ARG (sc, mach_msg_type_name_t, realnodePoly, number, args);
-+  SC_ARG (sc, mach_msg_timeout_t, timeout, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t control;
-+  err = service_fsys_request (bootstrap,
-+			      realnode,
-+			      realnodePoly,
-+			      timeout,
-+			      &control);
-+  SC_RETURN_INT (sc, control);
-+}
-+
-+pointer
-+do_bind_root (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("_bind-root");
-+  SC_ARG (sc, mach_port_t, control, number, args);
-+  SC_ARG (sc, file_t, dotdot_node, number, args);
-+  SC_ARGS_DONE (sc);
-+  if (! MACH_PORT_VALID (control)
-+      || ! MACH_PORT_VALID (dotdot_node))
-+    SC_RETURN_ERR (sc, EINVAL);
-+
-+  if (_hurd_ports)
-+    SC_RETURN_ERR (sc, EPERM); /* XXX */
-+
-+  uid_t uids[1] = { 0 };
-+  size_t uids_len = 1;
-+  gid_t gids[1] = { 0 };
-+  size_t gids_len = 1;
-+
-+  retry_type retry;
-+  char retryname[1024]; /* XXX */
-+  file_t root;
-+  err = fsys_getroot (control,
-+		      dotdot_node,
-+		      MACH_MSG_TYPE_MAKE_SEND,
-+		      uids, uids_len,
-+		      gids, gids_len,
-+		      (O_READ|O_EXEC),
-+		      &retry,
-+		      retryname,
-+		      &root);
-+  if (err)
-+    SC_RETURN (sc);
-+
-+  // XXX check root
-+  portarray_template[INIT_PORT_CRDIR] = root;
-+  portarray_template[INIT_PORT_CWDIR] = root;
-+
-+  err = mach_port_mod_refs (mach_task_self (),
-+			    root, MACH_PORT_RIGHT_SEND, +2);
-+  assert_perror (err);
-+
-+  /* We have no portarray or intarray because there was no
-+     exec_startup data; _hurd_init was never called.  We now have the
-+     crucial ports, so create a portarray and call _hurd_init.	*/
-+  mach_port_t *portarray;
-+  portarray = mmap (0, INIT_PORT_MAX * sizeof *portarray,
-+		    PROT_READ|PROT_WRITE, MAP_ANON, 0, 0);
-+  memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray);
-+  _hurd_init (0, NULL, portarray, INIT_PORT_MAX, NULL, 0);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_bind_proc (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("bind-proc");
-+  SC_ARG (sc, mach_port_t, procserver, number, args);
-+  SC_ARGS_DONE (sc);
-+  /* Give the library our proc server port.  */
-+  _hurd_port_set (&_hurd_ports[INIT_PORT_PROC], procserver);
-+  err = mach_port_mod_refs (mach_task_self (),
-+			    procserver, MACH_PORT_RIGHT_SEND, +1);
-+  assert_perror (err);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_bind_auth (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("bind-auth");
-+  SC_ARG (sc, mach_port_t, authserver, number, args);
-+  SC_ARGS_DONE (sc);
-+  /* Give the library our auth server port.  */
-+  _hurd_port_set (&_hurd_ports[INIT_PORT_AUTH], authserver);
-+  portarray_template[INIT_PORT_AUTH] = authserver;
-+  err = mach_port_mod_refs (mach_task_self (),
-+			    authserver, MACH_PORT_RIGHT_SEND, +2);
-+  assert_perror (err);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_bind_term (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("bind-term");
-+  SC_ARG (sc, mach_port_t, term, number, args);
-+  SC_ARGS_DONE (sc);
-+  int fd;
-+
-+  close (0);
-+  close (1);
-+  close (2);
-+
-+  fd = openport (copy_send_right (term), O_RDONLY);
-+  if (fd < 0)
-+    SC_RETURN_ERR (sc, errno);
-+  assert (fd == 0);
-+
-+  fd = openport (copy_send_right (term), O_WRONLY);
-+  if (fd < 0)
-+    SC_RETURN_ERR (sc, errno);
-+  assert (fd == 1);
-+
-+  fd = openport (copy_send_right (term), O_WRONLY);
-+  if (fd < 0)
-+    SC_RETURN_ERR (sc, errno);
-+  assert (fd == 2);
-+
-+  fclose (stdin);
-+  fclose (stdout);
-+  fclose (stderr);
-+  stdin = fdopen (0, "r");
-+  stdout = fdopen (1, "w");
-+  stderr = fdopen (2, "w");
-+
-+  scheme_set_input_port_file (sc, stdin);
-+  scheme_set_output_port_file (sc, stdout);
-+
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_fsys_init (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("fsys-init!");
-+  SC_ARG (sc, mach_port_t, fsys, number, args);
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARG (sc, mach_port_t, auth, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = fsys_init (fsys, proc, MACH_MSG_TYPE_COPY_SEND, auth);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_proc_task2proc (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc-task2proc");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t result;
-+  err = proc_task2proc (proc, task, &result);
-+  SC_RETURN_INT (sc, result);
-+}
-+
-+pointer
-+do_proc_task2pid (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc-task2pid");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARGS_DONE (sc);
-+  pid_t pid;
-+  err = proc_task2pid (proc, task, &pid);
-+  SC_RETURN_INT (sc, pid);
-+}
-+
-+pointer
-+do_proc_wait (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc-wait");
-+  SC_ARG (sc, process_t, proc, number, args);
-+  SC_ARG (sc, pid_t, pid, number, args);
-+  SC_ARG (sc, int, options, number, args);
-+  SC_ARGS_DONE (sc);
-+  int status, sigcode;
-+  rusage_t rusage; // XXX
-+  pid_t pid_status;
-+  err = proc_wait (proc, pid, options,
-+                   &status, &sigcode, &rusage, &pid_status);
-+#define IMC(A, B)	_cons (sc, sc->vptr->mk_integer (sc, A), (B), 1)
-+  SC_RETURN_POINTER (sc, IMC (status,
-+                              IMC (sigcode,
-+                                   IMC (pid_status, sc->NIL))));
-+#undef IMC
-+}
-+
-+pointer
-+do_proc_mark_exec (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc-mark-exec!");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = proc_mark_exec (proc);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_proc_mark_important (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc->mark-important!");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = proc_mark_important (proc);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_proc_child (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc->proc->child!");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARG (sc, mach_port_t, child, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = proc_child (proc, child);
-+  if (err) error (0, err, "proc_child");
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_proc_set_init_task (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc->task->set-init-task!");
-+  SC_ARG (sc, mach_port_t, proc, number, args);
-+  SC_ARG (sc, mach_port_t, task, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = proc_set_init_task (proc, task);
-+  SC_RETURN (sc);
-+}
-+
-+/* Set up the initial value of the standard exec data. */
-+/* XXX: Provide primitives and implement in Scheme.  */
-+pointer
-+do_proc_auth_set_std_execdata (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("proc->auth->set-std-execdata!");
-+  SC_ARG (sc, process_t, proc, number, args);
-+  SC_ARG (sc, auth_t, auth, number, args);
-+  SC_ARGS_DONE (sc);
-+
-+  auth_t nullauth;
-+  mach_port_t pt;
-+  mach_port_t ref;
-+  mach_port_t *std_port_array;
-+  int *std_int_array;
-+  int i;
-+
-+  std_port_array = alloca (sizeof (mach_port_t) * INIT_PORT_MAX);
-+  memset (std_port_array, 0, sizeof(mach_port_t) * INIT_PORT_MAX);
-+  std_int_array = alloca (sizeof (int) * INIT_INT_MAX);
-+  memset (std_int_array, 0, sizeof(int) * INIT_INT_MAX);
-+
-+  err = auth_makeauth (auth,
-+		       NULL, MACH_MSG_TYPE_COPY_SEND, 0,
-+		       NULL, 0,
-+		       NULL, 0,
-+		       NULL, 0,
-+		       NULL, 0,
-+		       &nullauth);
-+  if (err)
-+    goto out;
-+
-+  /* MAKE_SEND is safe in these transactions because we destroy REF
-+     ourselves each time. */
-+  pt = getcwdir ();
-+  ref = mach_reply_port ();
-+  err = io_reauthenticate (pt, ref, MACH_MSG_TYPE_MAKE_SEND);
-+  if (err)
-+    goto out;
-+
-+  err = auth_user_authenticate (nullauth, ref, MACH_MSG_TYPE_MAKE_SEND,
-+				&std_port_array[INIT_PORT_CWDIR]);
-+  if (err)
-+    goto out;
-+
-+  mach_port_destroy (mach_task_self (), ref);
-+  mach_port_deallocate (mach_task_self (), pt);
-+
-+  pt = getcrdir ();
-+  ref = mach_reply_port ();
-+  err = io_reauthenticate (pt, ref, MACH_MSG_TYPE_MAKE_SEND);
-+  if (err)
-+    goto out;
-+
-+  err = auth_user_authenticate (nullauth, ref, MACH_MSG_TYPE_MAKE_SEND,
-+				&std_port_array[INIT_PORT_CRDIR]);
-+  if (err)
-+    goto out;
-+
-+  mach_port_destroy (mach_task_self (), ref);
-+  mach_port_deallocate (mach_task_self (), pt);
-+
-+  std_port_array[INIT_PORT_AUTH] = nullauth;
-+  std_int_array[INIT_UMASK] = CMASK;
-+
-+  err = proc_setexecdata (proc, std_port_array,
-+			  MACH_MSG_TYPE_COPY_SEND, INIT_PORT_MAX,
-+			  std_int_array, INIT_INT_MAX);
-+
-+ out:
-+  for (i = 0; i < INIT_PORT_MAX; i++)
-+    if (MACH_PORT_VALID (std_port_array[i]))
-+      {
-+	error_t err;
-+	err = mach_port_deallocate (mach_task_self (), std_port_array[i]);
-+	assert_perror (err);
-+      }
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_file_set_translator (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("file-set-translator");
-+  SC_ARG (sc, file_t, node, number, args);
-+  SC_ARG (sc, int, passive_flags, number, args);
-+  SC_ARG (sc, int, active_flags, number, args);
-+  SC_ARG (sc, int, goaway_flags, number, args);
-+  SC_ARG (sc, int, argz, number, args); //XXX
-+  SC_ARG (sc, int, argz_len, number, args); //XXX
-+  argz = argz_len = 0;
-+
-+  SC_ARG (sc, mach_port_t, active_control, number, args);
-+  SC_ARG (sc, mach_msg_type_name_t, active_controlPoly, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = file_set_translator (node,
-+			     passive_flags, active_flags, goaway_flags,
-+			     argz, argz_len,
-+			     active_control, active_controlPoly);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+ffi_argz2list (scheme *sc, const char *argz, size_t argz_len, const char *entry)
-+{
-+  entry = argz_next (argz, argz_len, entry);
-+  if (argz == NULL || argz_len == 0 || entry == NULL)
-+    return sc->NIL;
-+  return _cons (sc,
-+		mk_string (sc, entry),
-+		ffi_argz2list (sc, argz, argz_len, entry),
-+		1);
-+}
-+
-+void
-+ffi_list2argz (scheme *sc, char **argz, size_t *argz_len, pointer list)
-+{
-+  while (sc->vptr->is_pair (list))
-+    {
-+      argz_add (argz, argz_len, string_value (sc->vptr->pair_car (list)));
-+      list = sc->vptr->pair_cdr (list);
-+    }
-+}
-+
-+// XXX
-+pointer
-+do__exec (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("_exec");
-+  process_t proc, child_proc = MACH_PORT_NULL;
-+  mach_port_t dtable[STDERR_FILENO+1];
-+  mach_port_t portarray[INIT_PORT_MAX];
-+  int default_ints[INIT_INT_MAX];
-+  char *argz = NULL;
-+  size_t argz_len = 0;
-+  int i;
-+
-+  SC_ARG (sc, file_t, file, number, args);
-+  SC_ARG (sc, task_t, task, number, args);
-+  SC_ARG (sc, pointer, arguments, list, args);
-+  ffi_list2argz (sc, &argz, &argz_len, arguments);
-+  SC_ARG (sc, mach_port_t, bootstrap, number, args);
-+  SC_ARGS_DONE (sc);
-+
-+  proc = getproc ();
-+  if (MACH_PORT_VALID (proc))
-+    {
-+      err = proc_task2proc (proc, task, &child_proc);
-+      mach_port_deallocate (mach_task_self (), proc);
-+      if (err)
-+	SC_RETURN (sc);
-+    }
-+
-+  dtable[STDIN_FILENO] = file_name_lookup ("/dev/console", O_RDONLY, 0);
-+  dtable[STDOUT_FILENO] = file_name_lookup ("/dev/console", O_WRONLY, 0);
-+  dtable[STDERR_FILENO] = file_name_lookup ("/dev/console", O_WRONLY, 0);
-+
-+  memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray);
-+  for (i = 0; i < INIT_PORT_MAX; i++)
-+    copy_send_right (portarray[i]);
-+
-+  portarray[INIT_PORT_CWDIR] = getcwdir ();
-+  portarray[INIT_PORT_CRDIR] = getcrdir ();
-+  portarray[INIT_PORT_PROC] = child_proc;
-+  portarray[INIT_PORT_BOOTSTRAP] = copy_send_right (bootstrap);
-+
-+  memset (default_ints, 0, INIT_INT_MAX * sizeof *default_ints);
-+  /* All programs we start should ignore job control stop signals.
-+     That way Posix.1 B.2.2.2 is satisfied where it says that programs
-+     not run under job control shells are protected.  */
-+  default_ints[INIT_SIGIGN] = (sigmask (SIGTSTP)
-+			       | sigmask (SIGTTIN)
-+			       | sigmask (SIGTTOU));
-+
-+  err = task_set_name (task, argz);
-+  if (err)
-+    {
-+      error (0, err, "task_set_name");
-+      goto lose;
-+    }
-+
-+  err = file_exec (file, task, 0,
-+		   argz, argz_len,
-+		   NULL, 0, /* env, env_len */
-+		   dtable, MACH_MSG_TYPE_COPY_SEND, 3,
-+		   portarray, MACH_MSG_TYPE_COPY_SEND, INIT_PORT_MAX,
-+		   default_ints, INIT_INT_MAX,
-+		   NULL, 0, NULL, 0);
-+
-+ lose:
-+  for (i = 0; i < STDERR_FILENO+1; i++)
-+    if (MACH_PORT_VALID (dtable[i]))
-+      {
-+	error_t err = mach_port_deallocate (mach_task_self (), dtable[i]);
-+	assert_perror (err);
-+      }
-+  for (i = 0; i < INIT_PORT_MAX; i++)
-+    if (MACH_PORT_VALID (portarray[i]))
-+      {
-+	error_t err = mach_port_deallocate (mach_task_self (), portarray[i]);
-+	assert_perror (err);
-+      }
-+
-+  SC_RETURN_INT (sc, task);
-+}
-+
-+pointer
-+do_file_get_fs_options (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("file-get-fs-options");
-+  SC_ARG (sc, file_t, node, number, args);
-+  SC_ARGS_DONE (sc);
-+  char *argz = NULL;
-+  size_t argz_len = 0;
-+  pointer result;
-+  err = file_get_fs_options (node, &argz, &argz_len);
-+  if (err)
-+    SC_RETURN (sc);
-+  result = ffi_argz2list (sc, argz, argz_len, NULL);
-+  vm_deallocate (mach_task_self (), (vm_address_t) argz, argz_len);
-+  SC_RETURN_POINTER (sc, result);
-+}
-+
-+const char *
-+schemify_name (const char *s, int macro)
-+{
-+  char *n = strdup (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;
-+}
-+
-+void
-+ffi_update (scheme *sc)
-+{
-+  // XXX nothng
-+}
-+
-+void
-+ffi_init (scheme *sc)
-+{
-+  char *version;
-+  asprintf (&version, "%s/%s", argp_program_version, "TinyScheme 1.41");
-+  define_ (sc, "version", mk_string (sc, version));
-+  free (version);
-+
-+  define_constant (sc, MACH_PORT_NULL);
-+  define_constant (sc, MACH_PORT_DEAD); // XXX signedness
-+
-+  define_constant (sc, MACH_MSG_TYPE_UNSTRUCTURED);
-+  define_constant (sc, MACH_MSG_TYPE_BIT);
-+  define_constant (sc, MACH_MSG_TYPE_BOOLEAN);
-+  define_constant (sc, MACH_MSG_TYPE_INTEGER_16);
-+  define_constant (sc, MACH_MSG_TYPE_INTEGER_32);
-+  define_constant (sc, MACH_MSG_TYPE_CHAR);
-+  define_constant (sc, MACH_MSG_TYPE_BYTE);
-+  define_constant (sc, MACH_MSG_TYPE_INTEGER_8);
-+  define_constant (sc, MACH_MSG_TYPE_REAL);
-+  define_constant (sc, MACH_MSG_TYPE_INTEGER_64);
-+  define_constant (sc, MACH_MSG_TYPE_STRING);
-+  define_constant (sc, MACH_MSG_TYPE_STRING_C);
-+  define_constant (sc, MACH_MSG_TYPE_MOVE_RECEIVE);
-+  define_constant (sc, MACH_MSG_TYPE_MOVE_SEND);
-+  define_constant (sc, MACH_MSG_TYPE_MOVE_SEND_ONCE);
-+  define_constant (sc, MACH_MSG_TYPE_COPY_SEND);
-+  define_constant (sc, MACH_MSG_TYPE_MAKE_SEND);
-+  define_constant (sc, MACH_MSG_TYPE_MAKE_SEND_ONCE);
-+  define_constant (sc, MACH_MSG_TYPE_PORT_NAME);
-+  define_constant (sc, MACH_MSG_TYPE_PORT_RECEIVE);
-+  define_constant (sc, MACH_MSG_TYPE_PORT_SEND);
-+  define_constant (sc, MACH_MSG_TYPE_PORT_SEND_ONCE);
-+  define_constant (sc, MACH_MSG_TYPE_PROTECTED_PAYLOAD);
-+  define_constant (sc, MACH_MSG_TYPE_LAST);
-+  define_constant (sc, MACH_MSG_TYPE_POLYMORPHIC);
-+
-+  define_constant (sc, MACH_PORT_RIGHT_SEND);
-+  define_constant (sc, MACH_PORT_RIGHT_RECEIVE);
-+  define_constant (sc, MACH_PORT_RIGHT_SEND_ONCE);
-+  define_constant (sc, MACH_PORT_RIGHT_PORT_SET);
-+  define_constant (sc, MACH_PORT_RIGHT_DEAD_NAME);
-+  define_constant (sc, MACH_PORT_RIGHT_NUMBER);
-+
-+  define_constant (sc, KERN_SUCCESS);
-+  define_constant (sc, KERN_INVALID_ADDRESS);
-+  define_constant (sc, KERN_PROTECTION_FAILURE);
-+  define_constant (sc, KERN_NO_SPACE);
-+  define_constant (sc, KERN_INVALID_ARGUMENT);
-+  define_constant (sc, KERN_FAILURE);
-+  define_constant (sc, KERN_RESOURCE_SHORTAGE);
-+  define_constant (sc, KERN_NOT_RECEIVER);
-+  define_constant (sc, KERN_NO_ACCESS);
-+  define_constant (sc, KERN_MEMORY_FAILURE);
-+  define_constant (sc, KERN_MEMORY_ERROR);
-+  define_constant (sc, KERN_NOT_IN_SET);
-+  define_constant (sc, KERN_NAME_EXISTS);
-+  define_constant (sc, KERN_ABORTED);
-+  define_constant (sc, KERN_INVALID_NAME);
-+  define_constant (sc, KERN_INVALID_TASK);
-+  define_constant (sc, KERN_INVALID_RIGHT);
-+  define_constant (sc, KERN_INVALID_VALUE);
-+  define_constant (sc, KERN_UREFS_OVERFLOW);
-+  define_constant (sc, KERN_INVALID_CAPABILITY);
-+  define_constant (sc, KERN_RIGHT_EXISTS);
-+  define_constant (sc, KERN_INVALID_HOST);
-+  define_constant (sc, KERN_MEMORY_PRESENT);
-+  define_constant (sc, KERN_WRITE_PROTECTION_FAILURE);
-+  define_constant (sc, KERN_TERMINATED);
-+  define_constant (sc, MACH_MSG_SUCCESS);
-+  define_constant (sc, MACH_MSG_MASK);
-+  define_constant (sc, MACH_MSG_IPC_SPACE);
-+  define_constant (sc, MACH_MSG_VM_SPACE);
-+  define_constant (sc, MACH_MSG_IPC_KERNEL);
-+  define_constant (sc, MACH_MSG_VM_KERNEL);
-+  define_constant (sc, MACH_SEND_IN_PROGRESS);
-+  define_constant (sc, MACH_SEND_INVALID_DATA);
-+  define_constant (sc, MACH_SEND_INVALID_DEST);
-+  define_constant (sc, MACH_SEND_TIMED_OUT);
-+  define_constant (sc, MACH_SEND_WILL_NOTIFY);
-+  define_constant (sc, MACH_SEND_NOTIFY_IN_PROGRESS);
-+  define_constant (sc, MACH_SEND_INTERRUPTED);
-+  define_constant (sc, MACH_SEND_MSG_TOO_SMALL);
-+  define_constant (sc, MACH_SEND_INVALID_REPLY);
-+  define_constant (sc, MACH_SEND_INVALID_RIGHT);
-+  define_constant (sc, MACH_SEND_INVALID_NOTIFY);
-+  define_constant (sc, MACH_SEND_INVALID_MEMORY);
-+  define_constant (sc, MACH_SEND_NO_BUFFER);
-+  define_constant (sc, MACH_SEND_NO_NOTIFY);
-+  define_constant (sc, MACH_SEND_INVALID_TYPE);
-+  define_constant (sc, MACH_SEND_INVALID_HEADER);
-+  define_constant (sc, MACH_RCV_IN_PROGRESS);
-+  define_constant (sc, MACH_RCV_INVALID_NAME);
-+  define_constant (sc, MACH_RCV_TIMED_OUT);
-+  define_constant (sc, MACH_RCV_TOO_LARGE);
-+  define_constant (sc, MACH_RCV_INTERRUPTED);
-+  define_constant (sc, MACH_RCV_PORT_CHANGED);
-+  define_constant (sc, MACH_RCV_INVALID_NOTIFY);
-+  define_constant (sc, MACH_RCV_INVALID_DATA);
-+  define_constant (sc, MACH_RCV_PORT_DIED);
-+  define_constant (sc, MACH_RCV_IN_SET);
-+  define_constant (sc, MACH_RCV_HEADER_ERROR);
-+  define_constant (sc, MACH_RCV_BODY_ERROR);
-+
-+  define_constant (sc, TASK_KERNEL_PORT);
-+  define_constant (sc, TASK_EXCEPTION_PORT);
-+  define_constant (sc, TASK_BOOTSTRAP_PORT);
-+
-+  define_constant (sc, RB_DEBUGGER);
-+  define_constant (sc, RB_HALT);
-+  define_constant (sc, RB_AUTOBOOT);
-+
-+  define_ (sc, "mach-task-self", mk_integer (sc, mach_task_self ()));
-+
-+  define_function (sc, "mach-port-allocate", mach_port_allocate);
-+  define_function (sc, "mach-port-deallocate", mach_port_deallocate);
-+  define_function (sc, "mach-port-destroy", mach_port_destroy);
-+  //define_function (sc, "mach-port-get-refs", mach_port_get_refs);
-+  //define_function (sc, "mach-port-mod-refs", mach_port_mod_refs);
-+  define_function (sc, "mach-port-insert-right", mach_port_insert_right);
-+  //define_function (sc, "mach-port-extract-right", mach_port_extract_right);
-+
-+  define_function (sc, "mach-print", mach_print);
-+  define_function (sc, "task-create", task_create);
-+  define_function (sc, "task-resume", task_resume);
-+  define_function (sc, "task-terminate", task_terminate);
-+  define_function (sc, "task-get-special-port", task_get_special_port);
-+  define_function (sc, "task-set-special-port", task_set_special_port);
-+  define_function (sc, "host-reboot", host_reboot);
-+
-+  /* Device protocol.  */
-+  define_constant (sc, D_READ);
-+  define_constant (sc, D_WRITE);
-+  define_function (sc, "device-open", device_open);
-+
-+  /* Hurd stuff.  */
-+  define_constant (sc, EXEC_NEWTASK);
-+  define_constant (sc, EXEC_SECURE);
-+  define_constant (sc, EXEC_DEFAULTS);
-+  define_constant (sc, EXEC_SIGTRAP);
-+  define_constant (sc, EXEC_STACK_ARGS);
-+  define_constant (sc, FS_TRANS_FORCE);
-+  define_constant (sc, FS_TRANS_EXCL);
-+  define_constant (sc, FS_TRANS_SET);
-+  define_constant (sc, FS_TRANS_ORPHAN);
-+  define_constant (sc, FS_RETRY_NORMAL);
-+  define_constant (sc, FS_RETRY_REAUTH);
-+  define_constant (sc, FS_RETRY_MAGICAL);
-+  define_constant (sc, FSYS_GOAWAY_NOWAIT);
-+  define_constant (sc, FSYS_GOAWAY_NOSYNC);
-+  define_constant (sc, FSYS_GOAWAY_FORCE);
-+  define_constant (sc, FSYS_GOAWAY_UNLINK);
-+  define_constant (sc, FSYS_GOAWAY_RECURSE);
-+  define_constant (sc, INIT_PORT_CWDIR);
-+  define_constant (sc, INIT_PORT_CRDIR);
-+  define_constant (sc, INIT_PORT_AUTH);
-+  define_constant (sc, INIT_PORT_PROC);
-+  define_constant (sc, INIT_PORT_CTTYID);
-+  define_constant (sc, INIT_PORT_BOOTSTRAP);
-+  define_constant (sc, INIT_PORT_MAX);
-+  define_constant (sc, INIT_UMASK);
-+  define_constant (sc, INIT_SIGMASK);
-+  define_constant (sc, INIT_SIGIGN);
-+  define_constant (sc, INIT_SIGPENDING);
-+  define_constant (sc, INIT_TRACEMASK);
-+  define_constant (sc, INIT_INT_MAX);
-+
-+  define_constant (sc, O_RDONLY);
-+  define_constant (sc, O_WRONLY);
-+  define_constant (sc, O_RDWR);
-+  define_constant (sc, O_EXEC);
-+  define_constant (sc, O_CREAT);
-+  define_constant (sc, O_NOTRANS);
-+
-+  define_variable (sc, exception_port);
-+  define_variable (sc, rootnode);
-+
-+  /* glibc.  */
-+  define_function (sc, "sleep", sleep);
-+  define_function (sc, "usleep", usleep);
-+  define_function (sc, "getcwd", getcwd);
-+  define_function (sc, "chdir", chdir);
-+  define_function (sc, "strerror", strerror);
-+  define_function (sc, "getproc", getproc);
-+
-+  /* Boot process */
-+  define_function (sc, "bind-root", bind_root);
-+  define_function (sc, "bind-proc", bind_proc);
-+  define_function (sc, "bind-auth", bind_auth);
-+  define_function (sc, "bind-term", bind_term);
-+  define_function (sc, "fsys-init", fsys_init);
-+
-+  /* Early bootstrap protocols.	 */
-+  define_function (sc, "handle-startup-procinit", handle_startup_procinit);
-+  define_function (sc, "handle-startup-authinit", handle_startup_authinit);
-+  define_function (sc, "startup-procinit-reply", startup_procinit_reply);
-+  define_function (sc, "startup-authinit-reply", startup_authinit_reply);
-+
-+  define_function (sc, "startup-essential-task", startup_essential_task);
-+  define_function (sc, "startup-request-notification",
-+		       startup_request_notification);
-+  define_function (sc, "startup-reboot", startup_reboot);
-+
-+  /* Process and translator startup.  */
-+  define_function (sc, "handle-exec-startup", handle_exec_startup);
-+  define_function (sc, "handle-fsys-startup", handle_fsys_startup);
-+
-+  /* Hurd fs API */
-+  define_function (sc, "file-name-lookup", file_name_lookup);
-+  define_function (sc, "file-set-translator", file_set_translator);
-+  define_function (sc, "file-get-fs-options", file_get_fs_options);
-+
-+  /* Hurd process API */
-+  define_function (sc, "proc-wait!", proc_wait);
-+  define_function (sc, "proc->task->proc", proc_task2proc);
-+  define_function (sc, "proc->task->pid", proc_task2pid);
-+  define_function (sc, "proc->mark-important!", proc_mark_important);
-+  define_function (sc, "proc->mark-exec!", proc_mark_exec);
-+  define_function (sc, "proc->task->child!", proc_child);
-+  define_function (sc, "proc->task->set-init-task!", proc_set_init_task);
-+
-+  /* Hurd hacks.  */
-+  define_function (sc, "_exec", _exec);
-+  define_function (sc, "start-handling-early-startup",
-+		       start_handling_early_startup);
-+  define_function (sc, "get-essential-tasks", get_essential_tasks);
-+  define_function (sc, "get-registered-tasks", get_registered_tasks);
-+  define_function (sc, "proc->auth->set-std-execdata!",
-+                   proc_auth_set_std_execdata);
-+
-+  /* User interface.  */
-+  define_function (sc, "enable-readline", enable_readline);
-+  define_function (sc, "prompt", prompt);
-+
-+  /* XXX */
-+  ffi_update (sc);
-+}
-diff --git a/bootshell/ffi.h b/bootshell/ffi.h
-new file mode 100644
-index 0000000..a57fe3f
---- /dev/null
-+++ b/bootshell/ffi.h
-@@ -0,0 +1,130 @@
-+#ifndef _HURD_BOOTSHELL_FFI_H
-+#define _HURD_BOOTSHELL_FFI_H
-+
-+#include <mach.h>
-+#include <mach/message.h>
-+
-+#include "scheme.h"
-+#include "scheme-private.h"
-+
-+#define SC_FFI_PROLOG(NAME)                                     \
-+  const char *__ffi_name __attribute__ ((unused)) = NAME;       \
-+  unsigned int __ffi_arg_index __attribute__ ((unused)) = 1;    \
-+  error_t err = 0;                                              \
-+
-+#define CONVERSION_number ivalue
-+#define CONVERSION_string string_value
-+#define CONVERSION_list
-+#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_list(SC, X)	(SC)->vptr->is_list (SC, X)
-+
-+#define SC_ARG(SC, CTYPE, TARGET, WANT, ARGS)				\
-+  if ((ARGS) == (SC)->NIL) {						\
-+    fprintf (stderr, "Error: %s: too few arguments: "			\
-+	     "want " #TARGET "("#WANT"/"#CTYPE")\n", __ffi_name);	\
-+    return (SC)->NIL;							\
-+  }									\
-+  if (! IS_A_##WANT ((SC), pair_car (ARGS))) {				\
-+    fprintf (stderr, "Error: %s: argument %d must be: "			\
-+	     #WANT "\n", __ffi_name, __ffi_arg_index++);		\
-+    return (SC)->NIL;							\
-+  }									\
-+  CTYPE TARGET = CONVERSION_##WANT (pair_car (ARGS));			\
-+  ARGS = pair_cdr (ARGS);						\
-+
-+#define SC_ARGS_DONE(SC)			\
-+  /* XXX */
-+
-+#define SC_RETURN_ERR(SC, ERR)					\
-+  return _cons ((SC), mk_integer ((SC), (ERR)), (SC)->NIL, 1)
-+
-+#define SC_RETURN(SC)	SC_RETURN_ERR (SC, err)
-+
-+#define SC_RETURN_POINTER(SC, X)					\
-+  return _cons ((SC), mk_integer ((SC), err),				\
-+		_cons ((SC), (X), (SC)->NIL, 1), 1)
-+#define SC_RETURN_INT(SC, X)						\
-+  SC_RETURN_POINTER ((SC), mk_integer ((SC), (X)))
-+#define SC_RETURN_STRING(SC, X)						\
-+  SC_RETURN_POINTER ((SC), mk_string ((SC), (X)))
-+
-+const char *schemify_name (const char *s, int macro);
-+
-+#define define_function(S, P, F)				\
-+  ({								\
-+  char _sc_buf[256];						\
-+  scheme_define ((S),						\
-+		 (S)->global_env,				\
-+		 mk_symbol ((S), schemify_name ("_" #F, 0)),	\
-+		 mk_foreign_func ((S), (do_##F)));              \
-+  snprintf (_sc_buf, sizeof _sc_buf,				\
-+	    "(define (%1$s . a) (ffi-apply \"%1$s\" %2$s a))",  \
-+	    P, schemify_name ("_" #F, 0));			\
-+  scheme_load_string (S, _sc_buf);				\
-+  })
-+
-+#define define_constant(S, C)						\
-+  scheme_define ((S),							\
-+		 (S)->global_env,					\
-+		 mk_symbol ((S), schemify_name (#C, 1)),		\
-+		 mk_integer ((S), (C)))
-+
-+#define define_(S, SYM, EXP)				\
-+  scheme_define ((S), (S)->global_env, mk_symbol ((S), (SYM)), EXP)
-+
-+#define define_variable(S, C)						\
-+  scheme_define ((S),							\
-+		 (S)->global_env,					\
-+		 mk_symbol ((S), schemify_name (#C, 0)),		\
-+		 mk_integer ((S), (C)))
-+
-+#define define_variable_pointer(S, C, P)                                \
-+  scheme_define ((S),							\
-+		 (S)->global_env,					\
-+		 mk_symbol ((S), schemify_name (#C, 0)),		\
-+                 (P))
-+
-+#define define_variable_string(S, C)                            	\
-+  define_variable_pointer (S, C, (S)->vptr->mk_string (S, C ?: ""))
-+
-+/* A variant of scheme_load_string that does not require the string to
-+   be zero-terminated.  */
-+void scheme_load_mem (scheme *, const char *, const char *);
-+
-+#define declare_embedded_script(X)			    \
-+  extern char X##_size[]	asm("_binary__"#X"_o_size");  \
-+  extern char X##_start[]	asm("_binary__"#X"_o_start");  \
-+  extern char X##_end[]		asm("_binary__"#X"_o_end")
-+
-+#define load_embedded_script(S, X)					\
-+  ({									\
-+    scheme_load_mem ((S), X##_start, X##_end);				\
-+    if ((S)->retcode != 0)						\
-+      fprintf (stderr, "Errors encountered evaluating %s\n", #X);	\
-+  })
-+
-+declare_embedded_script (init);
-+declare_embedded_script (boot);
-+declare_embedded_script (runsystem);
-+
-+void ffi_update (scheme *sc);
-+void ffi_init (scheme *sc);
-+
-+pointer ffi_argz2list (scheme *sc,
-+                       const char *argz, size_t argz_len, const char *entry);
-+void ffi_list2argz (scheme *sc, char **argz, size_t *argz_len, pointer list);
-+
-+// XXX
-+error_t service_fsys_request (mach_port_t bootstrap,
-+			      mach_port_t realnode,
-+			      mach_msg_type_name_t realnodePoly,
-+			      mach_msg_timeout_t timeout,
-+			      mach_port_t *control);
-+
-+/* Forward declarations.  */
-+
-+/* exec-startup.c  */
-+pointer do_handle_exec_startup (scheme *sc, pointer args);
-+
-+#endif /* _HURD_BOOTSHELL_FFI_H */
-diff --git a/bootshell/fs.c b/bootshell/fs.c
-new file mode 100644
-index 0000000..3c8deb3
---- /dev/null
-+++ b/bootshell/fs.c
-@@ -0,0 +1,91 @@
-+#include <assert.h>
-+#include <hurd.h>
-+#include <mach.h>
-+#include <mach/message.h>
-+#include <pthread.h>
-+#include <stdio.h>
-+
-+// eek #include "fs_S.h"
-+
-+#include "bootshell.h"
-+
-+mach_port_t rootnode;
-+
-+/* A top-level function for the paging thread that just services paging
-+   requests.  */
-+static void *
-+service_fs_requests (void *arg)
-+{
-+  extern boolean_t fs_server ();
-+
-+  int trace_demuxer (mach_msg_header_t *inp,
-+		     mach_msg_header_t *outp)
-+  {
-+    error (0, 0, "(fs-server: %d)", inp->msgh_id);
-+    int i = fs_server (inp, outp);
-+    return i;
-+  }
-+
-+  while (1)
-+    mach_msg_server (0? trace_demuxer: fs_server, 0, rootnode);
-+
-+  /* Not reached.  */
-+  return NULL;
-+}
-+
-+error_t
-+init_fs_server (void)
-+{
-+  error_t err;
-+  pthread_t t;
-+
-+  err = mach_port_allocate (mach_task_self (),
-+			    MACH_PORT_RIGHT_RECEIVE,
-+			    &rootnode);
-+  if (err)
-+    return err;
-+
-+  /* Make a thread to service the fs protocol.	*/
-+  err = pthread_create (&t, NULL, service_fs_requests, NULL);
-+  if (err)
-+    return err;
-+  pthread_detach (t);
-+
-+  err = mach_port_insert_right (mach_task_self (),
-+				rootnode,
-+				rootnode,
-+				MACH_MSG_TYPE_MAKE_SEND);
-+  if (err)
-+    return err;
-+
-+  setcrdir (rootnode); // XXX do we want this? not sure what for tbh.
-+  setcwdir (rootnode);
-+  portarray_template[INIT_PORT_CRDIR] = rootnode;
-+  portarray_template[INIT_PORT_CWDIR] = rootnode;
-+
-+  return err;
-+}
-+
-+error_t
-+S_dir_lookup (file_t file,
-+	      char *path,
-+	      int flags,
-+	      mode_t mode,
-+	      enum retry_type *retry,
-+	      char *retryname,
-+	      file_t *returned_port,
-+	      mach_msg_type_name_t *returned_port_poly)
-+{
-+  if (file != rootnode)
-+    return EOPNOTSUPP;
-+
-+  if (portarray_template[INIT_PORT_CRDIR] == rootnode)
-+    /* Still no root filesystem.  */
-+    return EOPNOTSUPP;
-+
-+  *retry = FS_RETRY_NORMAL;
-+  strncpy (retryname, path, sizeof (string_t));
-+  *returned_port = portarray_template[INIT_PORT_CRDIR];
-+  *returned_port_poly = MACH_MSG_TYPE_COPY_SEND;
-+  return 0;
-+}
-diff --git a/bootshell/fsys.c b/bootshell/fsys.c
-new file mode 100644
-index 0000000..dbdeed6
---- /dev/null
-+++ b/bootshell/fsys.c
-@@ -0,0 +1,84 @@
-+#include <assert.h>
-+#include <hurd.h>
-+#include <mach.h>
-+#include <mach/message.h>
-+#include <mach/mig_support.h>
-+#include <stdio.h>
-+
-+// eek #include "fsys_S.h"
-+
-+#include "bootshell.h"
-+
-+/* XXX would be nice not to use a global variable, maybe with
-+   payloads.  */
-+static struct
-+{
-+  /* Filled by caller.	*/
-+  mach_port_t bootstrap_port;
-+  mach_port_t realnode;
-+  mach_msg_type_name_t realnodePoly;
-+
-+  /* Filled by the server function.  */
-+  mach_port_t control_port;
-+} fsys_startup_args;
-+
-+error_t
-+S_fsys_startup (mach_port_t bootstrap,
-+		int openflags,
-+		mach_port_t control_port,
-+		mach_port_t *realnode,
-+		mach_msg_type_name_t *realnodePoly)
-+{
-+  assert (MACH_PORT_VALID (fsys_startup_args.bootstrap_port));
-+  if (bootstrap != fsys_startup_args.bootstrap_port)
-+    return EOPNOTSUPP;
-+
-+  fsys_startup_args.control_port = control_port;
-+  *realnode = fsys_startup_args.realnode;
-+  *realnodePoly = fsys_startup_args.realnodePoly;
-+  return 0;
-+}
-+
-+static boolean_t
-+fsys_startup_demuxer (mach_msg_header_t *request,
-+		      mach_msg_header_t *reply)
-+{
-+  extern boolean_t fsys_server (mach_msg_header_t *, mach_msg_header_t *);
-+
-+  switch (request->msgh_id)
-+    {
-+    case 22000:	/* fsys_startup */
-+      return fsys_server (request, reply);
-+    }
-+
-+  /* Return MIG_BAD_ID.	 */
-+  mig_reply_setup (request, reply);
-+  return FALSE;
-+}
-+
-+error_t
-+service_fsys_request (mach_port_t bootstrap,
-+		      mach_port_t realnode,
-+		      mach_msg_type_name_t realnodePoly,
-+		      mach_msg_timeout_t timeout,
-+		      mach_port_t *control)
-+{
-+  error_t err;
-+
-+  if (! MACH_PORT_VALID (bootstrap))
-+    return EINVAL;
-+
-+  fsys_startup_args.bootstrap_port = bootstrap;
-+  fsys_startup_args.realnode = realnode;
-+  fsys_startup_args.realnodePoly = realnodePoly;
-+  fsys_startup_args.control_port = MACH_PORT_NULL;
-+
-+  err = mach_msg_server_timeout_once (fsys_startup_demuxer, 0, bootstrap,
-+				      MACH_RCV_TIMEOUT | MACH_SEND_TIMEOUT,
-+				      timeout);
-+  if (err != MACH_MSG_SUCCESS)
-+    return err;
-+
-+  *control = fsys_startup_args.control_port;
-+  return 0;
-+}
-diff --git a/bootshell/hack.txt b/bootshell/hack.txt
-new file mode 100644
-index 0000000..f3ee648
---- /dev/null
-+++ b/bootshell/hack.txt
-@@ -0,0 +1,244 @@
-+
-+                              How to hack TinyScheme
-+                              ----------------------
-+
-+     TinyScheme is easy to learn and modify. It is structured like a
-+     meta-interpreter, only it is written in C. All data are Scheme
-+     objects, which facilitates both understanding/modifying the
-+     code and reifying the interpreter workings.
-+
-+     In place of a dry description, we will pace through the addition
-+     of a useful new datatype: garbage-collected memory blocks.
-+     The interface will be:
-+
-+          (make-block <n> [<fill>]) makes a new block of the specified size
-+               optionally filling it with a specified byte
-+          (block? <obj>)
-+          (block-length <block>)
-+          (block-ref <block> <index>) retrieves byte at location
-+          (block-set! <block> <index> <byte>) modifies byte at location
-+     
-+     In the sequel, lines that begin with '>' denote lines to add to the
-+     code. Lines that begin with '|' are just citations of existing code.
-+     Lines that begin with X denote lines to be removed from the code.
-+
-+     First of all, we need to assign a typeid to our new type. Typeids
-+     in TinyScheme are small integers declared in the scheme_types enum
-+     located near the top of the scheme.c file; it begins with T_STRING.
-+     Add a new entry at the end, say T_MEMBLOCK. Remember to adjust the
-+     value of T_LAST_SYTEM_TYPE when adding new entries. There can be at
-+     most 31 types, but you don't have to worry about that limit yet.
-+
-+|       T_ENVIRONMENT=14,
-+X       T_LAST_SYSTEM_TYPE=14
-+>       T_MEMBLOCK=15,
-+>       T_LAST_SYSTEM_TYPE=15
-+|     };
-+
-+
-+     Then, some helper macros would be useful. Go to where is_string()
-+     and the rest are defined and add:
-+
-+>     INTERFACE INLINE int is_memblock(pointer p)     { return (type(p)==T_MEMBLOCK); }
-+
-+     This actually is a function, because it is meant to be exported by
-+     scheme.h. If no foreign function will ever manipulate a memory block,
-+     you can instead define it as a macro:
-+
-+>     #define is_memblock(p) (type(p)==T_MEMBLOCK)
-+
-+     Then we make space for the new type in the main data structure:
-+     struct cell. As it happens, the _string part of the union _object
-+     (that is used to hold character strings) has two fields that suit us:
-+
-+|         struct {
-+|              char   *_svalue;
-+|              int   _keynum;
-+|         } _string;
-+
-+     We can use _svalue to hold the actual pointer and _keynum to hold its
-+     length. If we couln't reuse existing fields, we could always add other
-+     alternatives in union _object.
-+
-+     We then proceed to write the function that actually makes a new block.
-+     For conformance reasons, we name it mk_memblock
-+
-+>     static pointer mk_memblock(scheme *sc, int len, char fill) {
-+>          pointer x;
-+>          char *p=(char*)sc->malloc(len);
-+>
-+>          if(p==0) {
-+>               return sc->NIL;
-+>          }
-+>          x = get_cell(sc, sc->NIL, sc->NIL);
-+>
-+>          typeflag(x) = T_MEMBLOCK|T_ATOM;
-+>          strvalue(x)=p;
-+>          keynum(x)=len;
-+>          memset(p,fill,len);
-+>          return (x);
-+>     }
-+
-+     The memory used by the MEMBLOCK will have to be freed when the cell
-+     is reclaimed during garbage collection. There is a placeholder for
-+     that staff, function finalize_cell(), currently handling strings only.
-+
-+|     static void finalize_cell(scheme *sc, pointer a) {
-+|       if(is_string(a)) {
-+|          sc->free(strvalue(a));
-+>       } else if(is_memblock(a)) {
-+>          sc->free(strvalue(a));
-+|       } else if(is_port(a)) {
-+
-+     There are no MEMBLOCK literals, so we don't concern ourselves with
-+     the READER part (yet!). We must cater to the PRINTER, though. We
-+     add one case more in atom2str().
-+
-+|     } else if (iscontinuation(l)) {
-+|          p = "#<CONTINUATION>";
-+>     } else if (is_memblock(l)) {
-+>          p = "#<MEMORY BLOCK>";
-+|     } else {
-+
-+     Whenever a MEMBLOCK is displayed, it will look like that.
-+     Now, we must add the interface functions: constructor, predicate,
-+     accessor, modifier. We must in fact create new op-codes for the virtual
-+     machine underlying TinyScheme. Since version 1.30, TinyScheme uses
-+     macros and a single source text to keep the enums and the dispatch table
-+     in sync. The op-codes are defined in the opdefines.h file with one line
-+     for each op-code. The lines in the file have six columns between the
-+     starting _OPDEF( and ending ): A, B, C, D, E, and OP.
-+     Note that this file uses unusually long lines to accomodate all the
-+     information; adjust your editor to handle this.
-+
-+     The purpose of the columns is:
-+       - Column A is the name of the subroutine that handles the op-code.
-+       - Column B is the name of the op-code function.
-+       - Columns C and D are the minimum and maximum number of arguments
-+         that are accepted by the op-code.
-+       - Column E is a set of flags that tells the interpreter the type of
-+         each of the arguments expected by the op-code.
-+       - Column OP is used in the scheme_opcodes enum located in the
-+         scheme-private.h file.
-+
-+     Op-codes are really just tags for a huge C switch, only this switch
-+     is broken up in to a number of different opexe_X functions. The
-+     correspondence is made in table "dispatch_table". There, we assign
-+     the new op-codes to opexe_2, where the equivalent ones for vectors
-+     are situated. We also assign a name for them, and specify the minimum
-+     and maximum arity (number of expected arguments). INF_ARG as a maximum
-+     arity means "unlimited".
-+
-+     For reasons of consistency, we add the new op-codes right after those
-+     for vectors:
-+
-+|     _OP_DEF(opexe_2, "vector-set!",                    3,  3,       TST_VECTOR TST_NATURAL TST_ANY,  OP_VECSET           )
-+>     _OP_DEF(opexe_2, "make-block",                     1,  2,       TST_NATURAL TST_CHAR,            OP_MKBLOCK          )
-+>     _OP_DEF(opexe_2, "block-length",                   1,  1,       T_MEMBLOCK,                      OP_BLOCKLEN         )
-+>     _OP_DEF(opexe_2, "block-ref",                      2,  2,       T_MEMBLOCK TST_NATURAL,          OP_BLOCKREF         )
-+>     _OP_DEF(opexe_2, "block-set!",                     1,  1,       T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET         )
-+|     _OP_DEF(opexe_3, "not",                            1,  1,       TST_NONE,                        OP_NOT              )
-+
-+     We add the predicate along with the other predicates in opexe_3:
-+
-+|     _OP_DEF(opexe_3, "vector?",                        1,  1,       TST_ANY,                         OP_VECTORP          )
-+>     _OP_DEF(opexe_3, "block?",                         1,  1,       TST_ANY,                         OP_BLOCKP           )
-+|     _OP_DEF(opexe_3, "eq?",                            2,  2,       TST_ANY,                         OP_EQ               )
-+
-+     All that remains is to write the actual code to do the processing and
-+     add it to the switch statement in opexe_2, after the OP_VECSET case.
-+
-+>     case OP_MKBLOCK: { /* make-block */
-+>          int fill=0;
-+>          int len;
-+>
-+>          if(!isnumber(car(sc->args))) {
-+>               Error_1(sc,"make-block: not a number:",car(sc->args));
-+>          }
-+>          len=ivalue(car(sc->args));
-+>          if(len<=0) {
-+>               Error_1(sc,"make-block: not positive:",car(sc->args));
-+>          }
-+>
-+>          if(cdr(sc->args)!=sc->NIL) {
-+>               if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) {
-+>                    Error_1(sc,"make-block: not a positive number:",cadr(sc->args));
-+>               }
-+>               fill=charvalue(cadr(sc->args))%255;
-+>          }
-+>          s_return(sc,mk_memblock(sc,len,(char)fill));
-+>     }
-+>
-+>     case OP_BLOCKLEN:  /* block-length */
-+>          if(!ismemblock(car(sc->args))) {
-+>               Error_1(sc,"block-length: not a memory block:",car(sc->args));
-+>          }
-+>          s_return(sc,mk_integer(sc,keynum(car(sc->args))));
-+>
-+>     case OP_BLOCKREF: { /* block-ref */
-+>          char *str;
-+>          int index;
-+>
-+>          if(!ismemblock(car(sc->args))) {
-+>               Error_1(sc,"block-ref: not a memory block:",car(sc->args));
-+>          }
-+>          str=strvalue(car(sc->args));
-+>
-+>          if(cdr(sc->args)==sc->NIL) {
-+>               Error_0(sc,"block-ref: needs two arguments");
-+>          }
-+>          if(!isnumber(cadr(sc->args))) {
-+>               Error_1(sc,"block-ref: not a number:",cadr(sc->args));
-+>          }
-+>          index=ivalue(cadr(sc->args));
-+>
-+>          if(index<0 || index>=keynum(car(sc->args))) {
-+>               Error_1(sc,"block-ref: out of bounds:",cadr(sc->args));
-+>          }
-+>
-+>          s_return(sc,mk_integer(sc,str[index]));
-+>     }
-+>
-+>     case OP_BLOCKSET: { /* block-set! */
-+>          char *str;
-+>          int index;
-+>          int c;
-+>
-+>          if(!ismemblock(car(sc->args))) {
-+>               Error_1(sc,"block-set!: not a memory block:",car(sc->args));
-+>          }
-+>          if(isimmutable(car(sc->args))) {
-+>               Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args));
-+>          }
-+>          str=strvalue(car(sc->args));
-+>
-+>          if(cdr(sc->args)==sc->NIL) {
-+>               Error_0(sc,"block-set!: needs three arguments");
-+>          }
-+>          if(!isnumber(cadr(sc->args))) {
-+>               Error_1(sc,"block-set!: not a number:",cadr(sc->args));
-+>          }
-+>          index=ivalue(cadr(sc->args));
-+>          if(index<0 || index>=keynum(car(sc->args))) {
-+>               Error_1(sc,"block-set!: out of bounds:",cadr(sc->args));
-+>          }
-+>
-+>          if(cddr(sc->args)==sc->NIL) {
-+>               Error_0(sc,"block-set!: needs three arguments");
-+>          }
-+>          if(!isinteger(caddr(sc->args))) {
-+>               Error_1(sc,"block-set!: not an integer:",caddr(sc->args));
-+>          }
-+>          c=ivalue(caddr(sc->args))%255;
-+>
-+>          str[index]=(char)c;
-+>          s_return(sc,car(sc->args));
-+>     }
-+
-+     Finally, do the same for the predicate in opexe_3.
-+
-+|     case OP_VECTORP:     /* vector? */
-+|          s_retbool(is_vector(car(sc->args)));
-+>     case OP_BLOCKP:     /* block? */
-+>          s_retbool(is_memblock(car(sc->args)));
-+|     case OP_EQ:         /* eq? */
-diff --git a/bootshell/init.scm b/bootshell/init.scm
-new file mode 100644
-index 0000000..223e421
---- /dev/null
-+++ b/bootshell/init.scm
-@@ -0,0 +1,716 @@
-+;    Initialization file for TinySCHEME 1.41
-+
-+; Per R5RS, up to four deep compositions should be defined
-+(define (caar x) (car (car x)))
-+(define (cadr x) (car (cdr x)))
-+(define (cdar x) (cdr (car x)))
-+(define (cddr x) (cdr (cdr x)))
-+(define (caaar x) (car (car (car x))))
-+(define (caadr x) (car (car (cdr x))))
-+(define (cadar x) (car (cdr (car x))))
-+(define (caddr x) (car (cdr (cdr x))))
-+(define (cdaar x) (cdr (car (car x))))
-+(define (cdadr x) (cdr (car (cdr x))))
-+(define (cddar x) (cdr (cdr (car x))))
-+(define (cdddr x) (cdr (cdr (cdr x))))
-+(define (caaaar x) (car (car (car (car x)))))
-+(define (caaadr x) (car (car (car (cdr x)))))
-+(define (caadar x) (car (car (cdr (car x)))))
-+(define (caaddr x) (car (car (cdr (cdr x)))))
-+(define (cadaar x) (car (cdr (car (car x)))))
-+(define (cadadr x) (car (cdr (car (cdr x)))))
-+(define (caddar x) (car (cdr (cdr (car x)))))
-+(define (cadddr x) (car (cdr (cdr (cdr x)))))
-+(define (cdaaar x) (cdr (car (car (car x)))))
-+(define (cdaadr x) (cdr (car (car (cdr x)))))
-+(define (cdadar x) (cdr (car (cdr (car x)))))
-+(define (cdaddr x) (cdr (car (cdr (cdr x)))))
-+(define (cddaar x) (cdr (cdr (car (car x)))))
-+(define (cddadr x) (cdr (cdr (car (cdr x)))))
-+(define (cdddar x) (cdr (cdr (cdr (car x)))))
-+(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
-+
-+;;;; Utility to ease macro creation
-+(define (macro-expand form)
-+     ((eval (get-closure-code (eval (car form)))) form))
-+
-+(define (macro-expand-all form)
-+   (if (macro? form)
-+      (macro-expand-all (macro-expand form))
-+      form))
-+
-+(define *compile-hook* macro-expand-all)
-+
-+
-+(macro (unless form)
-+     `(if (not ,(cadr form)) (begin ,@(cddr form))))
-+
-+(macro (when form)
-+     `(if ,(cadr form) (begin ,@(cddr form))))
-+
-+; DEFINE-MACRO Contributed by Andy Gaynor
-+(macro (define-macro dform)
-+  (if (symbol? (cadr dform))
-+    `(macro ,@(cdr dform))
-+    (let ((form (gensym)))
-+      `(macro (,(caadr dform) ,form)
-+         (apply (lambda ,(cdadr dform) ,@(cddr dform)) (cdr ,form))))))
-+
-+; Utilities for math. Notice that inexact->exact is primitive,
-+; but exact->inexact is not.
-+(define exact? integer?)
-+(define (inexact? x) (and (real? x) (not (integer? x))))
-+(define (even? n) (= (remainder n 2) 0))
-+(define (odd? n) (not (= (remainder n 2) 0)))
-+(define (zero? n) (= n 0))
-+(define (positive? n) (> n 0))
-+(define (negative? n) (< n 0))
-+(define complex? number?)
-+(define rational? real?)
-+(define (abs n) (if (>= n 0) n (- n)))
-+(define (exact->inexact n) (* n 1.0))
-+(define (<> n1 n2) (not (= n1 n2)))
-+
-+; min and max must return inexact if any arg is inexact; use (+ n 0.0)
-+(define (max . lst)
-+  (foldr (lambda (a b)
-+           (if (> a b)
-+             (if (exact? b) a (+ a 0.0))
-+             (if (exact? a) b (+ b 0.0))))
-+         (car lst) (cdr lst)))
-+(define (min . lst)
-+  (foldr (lambda (a b)
-+           (if (< a b)
-+             (if (exact? b) a (+ a 0.0))
-+             (if (exact? a) b (+ b 0.0))))
-+         (car lst) (cdr lst)))
-+
-+(define (succ x) (+ x 1))
-+(define (pred x) (- x 1))
-+(define gcd
-+  (lambda a
-+    (if (null? a)
-+      0
-+      (let ((aa (abs (car a)))
-+            (bb (abs (cadr a))))
-+         (if (= bb 0)
-+              aa
-+              (gcd bb (remainder aa bb)))))))
-+(define lcm
-+  (lambda a
-+    (if (null? a)
-+      1
-+      (let ((aa (abs (car a)))
-+            (bb (abs (cadr a))))
-+         (if (or (= aa 0) (= bb 0))
-+             0
-+             (abs (* (quotient aa (gcd aa bb)) bb)))))))
-+
-+
-+(define (string . charlist)
-+     (list->string charlist))
-+
-+(define (list->string charlist)
-+     (let* ((len (length charlist))
-+            (newstr (make-string len))
-+            (fill-string!
-+               (lambda (str i len charlist)
-+                    (if (= i len)
-+                         str
-+                         (begin (string-set! str i (car charlist))
-+                         (fill-string! str (+ i 1) len (cdr charlist)))))))
-+          (fill-string! newstr 0 len charlist)))
-+
-+(define (string-fill! s e)
-+     (let ((n (string-length s)))
-+          (let loop ((i 0))
-+               (if (= i n)
-+                    s
-+                    (begin (string-set! s i e) (loop (succ i)))))))
-+
-+(define (string->list s)
-+     (let loop ((n (pred (string-length s))) (l '()))
-+          (if (= n -1)
-+               l
-+               (loop (pred n) (cons (string-ref s n) l)))))
-+
-+(define (string-copy str)
-+     (string-append str))
-+
-+(define (string->anyatom str pred)
-+     (let* ((a (string->atom str)))
-+       (if (pred a) a
-+         (error "string->xxx: not a xxx" a))))
-+
-+(define (string->number str . base)
-+    (let ((n (string->atom str (if (null? base) 10 (car base)))))
-+        (if (number? n) n #f)))
-+
-+(define (anyatom->string n pred)
-+  (if (pred n)
-+      (atom->string n)
-+      (error "xxx->string: not a xxx" n)))
-+
-+(define (number->string n . base)
-+    (atom->string n (if (null? base) 10 (car base))))
-+
-+
-+(define (char-cmp? cmp a b)
-+     (cmp (char->integer a) (char->integer b)))
-+(define (char-ci-cmp? cmp a b)
-+     (cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
-+
-+(define (char=? a b) (char-cmp? = a b))
-+(define (char<? a b) (char-cmp? < a b))
-+(define (char>? a b) (char-cmp? > a b))
-+(define (char<=? a b) (char-cmp? <= a b))
-+(define (char>=? a b) (char-cmp? >= a b))
-+
-+(define (char-ci=? a b) (char-ci-cmp? = a b))
-+(define (char-ci<? a b) (char-ci-cmp? < a b))
-+(define (char-ci>? a b) (char-ci-cmp? > a b))
-+(define (char-ci<=? a b) (char-ci-cmp? <= a b))
-+(define (char-ci>=? a b) (char-ci-cmp? >= a b))
-+
-+; Note the trick of returning (cmp x y)
-+(define (string-cmp? chcmp cmp a b)
-+     (let ((na (string-length a)) (nb (string-length b)))
-+          (let loop ((i 0))
-+               (cond
-+                    ((= i na)
-+                         (if (= i nb) (cmp 0 0) (cmp 0 1)))
-+                    ((= i nb)
-+                         (cmp 1 0))
-+                    ((chcmp = (string-ref a i) (string-ref b i))
-+                         (loop (succ i)))
-+                    (else
-+                         (chcmp cmp (string-ref a i) (string-ref b i)))))))
-+
-+
-+(define (string=? a b) (string-cmp? char-cmp? = a b))
-+(define (string<? a b) (string-cmp? char-cmp? < a b))
-+(define (string>? a b) (string-cmp? char-cmp? > a b))
-+(define (string<=? a b) (string-cmp? char-cmp? <= a b))
-+(define (string>=? a b) (string-cmp? char-cmp? >= a b))
-+
-+(define (string-ci=? a b) (string-cmp? char-ci-cmp? = a b))
-+(define (string-ci<? a b) (string-cmp? char-ci-cmp? < a b))
-+(define (string-ci>? a b) (string-cmp? char-ci-cmp? > a b))
-+(define (string-ci<=? a b) (string-cmp? char-ci-cmp? <= a b))
-+(define (string-ci>=? a b) (string-cmp? char-ci-cmp? >= a b))
-+
-+(define (list . x) x)
-+
-+(define (foldr f x lst)
-+     (if (null? lst)
-+          x
-+          (foldr f (f x (car lst)) (cdr lst))))
-+
-+(define (unzip1-with-cdr . lists)
-+  (unzip1-with-cdr-iterative lists '() '()))
-+
-+(define (unzip1-with-cdr-iterative lists cars cdrs)
-+  (if (null? lists)
-+      (cons cars cdrs)
-+      (let ((car1 (caar lists))
-+            (cdr1 (cdar lists)))
-+        (unzip1-with-cdr-iterative
-+          (cdr lists)
-+          (append cars (list car1))
-+          (append cdrs (list cdr1))))))
-+
-+(define (map proc . lists)
-+  (if (null? lists)
-+      (apply proc)
-+      (if (null? (car lists))
-+        '()
-+        (let* ((unz (apply unzip1-with-cdr lists))
-+               (cars (car unz))
-+               (cdrs (cdr unz)))
-+          (cons (apply proc cars) (apply map (cons proc cdrs)))))))
-+
-+(define (for-each proc . lists)
-+  (if (null? lists)
-+      (apply proc)
-+      (if (null? (car lists))
-+        #t
-+        (let* ((unz (apply unzip1-with-cdr lists))
-+               (cars (car unz))
-+               (cdrs (cdr unz)))
-+          (apply proc cars) (apply map (cons proc cdrs))))))
-+
-+(define (list-tail x k)
-+    (if (zero? k)
-+        x
-+        (list-tail (cdr x) (- k 1))))
-+
-+(define (list-ref x k)
-+    (car (list-tail x k)))
-+
-+(define (last-pair x)
-+    (if (pair? (cdr x))
-+        (last-pair (cdr x))
-+        x))
-+
-+(define (head stream) (car stream))
-+
-+(define (tail stream) (force (cdr stream)))
-+
-+(define (vector-equal? x y)
-+     (and (vector? x) (vector? y) (= (vector-length x) (vector-length y))
-+          (let ((n (vector-length x)))
-+               (let loop ((i 0))
-+                    (if (= i n)
-+                         #t
-+                         (and (equal? (vector-ref x i) (vector-ref y i))
-+                              (loop (succ i))))))))
-+
-+(define (list->vector x)
-+     (apply vector x))
-+
-+(define (vector-fill! v e)
-+     (let ((n (vector-length v)))
-+          (let loop ((i 0))
-+               (if (= i n)
-+                    v
-+                    (begin (vector-set! v i e) (loop (succ i)))))))
-+
-+(define (vector->list v)
-+     (let loop ((n (pred (vector-length v))) (l '()))
-+          (if (= n -1)
-+               l
-+               (loop (pred n) (cons (vector-ref v n) l)))))
-+
-+;; The following quasiquote macro is due to Eric S. Tiedemann.
-+;;   Copyright 1988 by Eric S. Tiedemann; all rights reserved.
-+;;
-+;; Subsequently modified to handle vectors: D. Souflis
-+
-+(macro
-+ quasiquote
-+ (lambda (l)
-+   (define (mcons f l r)
-+     (if (and (pair? r)
-+              (eq? (car r) 'quote)
-+              (eq? (car (cdr r)) (cdr f))
-+              (pair? l)
-+              (eq? (car l) 'quote)
-+              (eq? (car (cdr l)) (car f)))
-+         (if (or (procedure? f) (number? f) (string? f))
-+               f
-+               (list 'quote f))
-+         (if (eqv? l vector)
-+               (apply l (eval r))
-+               (list 'cons l r)
-+               )))
-+   (define (mappend f l r)
-+     (if (or (null? (cdr f))
-+             (and (pair? r)
-+                  (eq? (car r) 'quote)
-+                  (eq? (car (cdr r)) '())))
-+         l
-+         (list 'append l r)))
-+   (define (foo level form)
-+     (cond ((not (pair? form))
-+               (if (or (procedure? form) (number? form) (string? form))
-+                    form
-+                    (list 'quote form))
-+               )
-+           ((eq? 'quasiquote (car form))
-+            (mcons form ''quasiquote (foo (+ level 1) (cdr form))))
-+           (#t (if (zero? level)
-+                   (cond ((eq? (car form) 'unquote) (car (cdr form)))
-+                         ((eq? (car form) 'unquote-splicing)
-+                          (error "Unquote-splicing wasn't in a list:"
-+                                 form))
-+                         ((and (pair? (car form))
-+                               (eq? (car (car form)) 'unquote-splicing))
-+                          (mappend form (car (cdr (car form)))
-+                                   (foo level (cdr form))))
-+                         (#t (mcons form (foo level (car form))
-+                                         (foo level (cdr form)))))
-+                   (cond ((eq? (car form) 'unquote)
-+                          (mcons form ''unquote (foo (- level 1)
-+                                                     (cdr form))))
-+                         ((eq? (car form) 'unquote-splicing)
-+                          (mcons form ''unquote-splicing
-+                                      (foo (- level 1) (cdr form))))
-+                         (#t (mcons form (foo level (car form))
-+                                         (foo level (cdr form)))))))))
-+   (foo 0 (car (cdr l)))))
-+
-+;;;;;Helper for the dynamic-wind definition.  By Tom Breton (Tehom)
-+(define (shared-tail x y)
-+   (let ((len-x (length x))
-+         (len-y (length y)))
-+      (define (shared-tail-helper x y)
-+         (if
-+            (eq? x y)
-+            x
-+            (shared-tail-helper (cdr x) (cdr y))))
-+
-+      (cond
-+         ((> len-x len-y)
-+            (shared-tail-helper
-+               (list-tail x (- len-x len-y))
-+               y))
-+         ((< len-x len-y)
-+            (shared-tail-helper
-+               x
-+               (list-tail y (- len-y len-x))))
-+         (#t (shared-tail-helper x y)))))
-+
-+;;;;;Dynamic-wind by Tom Breton (Tehom)
-+
-+;;Guarded because we must only eval this once, because doing so
-+;;redefines call/cc in terms of old call/cc
-+(unless (defined? 'dynamic-wind)
-+   (let
-+      ;;These functions are defined in the context of a private list of
-+      ;;pairs of before/after procs.
-+      (  (*active-windings* '())
-+         ;;We'll define some functions into the larger environment, so
-+         ;;we need to know it.
-+         (outer-env (current-environment)))
-+
-+      ;;Poor-man's structure operations
-+      (define before-func car)
-+      (define after-func  cdr)
-+      (define make-winding cons)
-+
-+      ;;Manage active windings
-+      (define (activate-winding! new)
-+         ((before-func new))
-+         (set! *active-windings* (cons new *active-windings*)))
-+      (define (deactivate-top-winding!)
-+         (let ((old-top (car *active-windings*)))
-+            ;;Remove it from the list first so it's not active during its
-+            ;;own exit.
-+            (set! *active-windings* (cdr *active-windings*))
-+            ((after-func old-top))))
-+
-+      (define (set-active-windings! new-ws)
-+         (unless (eq? new-ws *active-windings*)
-+            (let ((shared (shared-tail new-ws *active-windings*)))
-+
-+               ;;Define the looping functions.
-+               ;;Exit the old list.  Do deeper ones last.  Don't do
-+               ;;any shared ones.
-+               (define (pop-many)
-+                  (unless (eq? *active-windings* shared)
-+                     (deactivate-top-winding!)
-+                     (pop-many)))
-+               ;;Enter the new list.  Do deeper ones first so that the
-+               ;;deeper windings will already be active.  Don't do any
-+               ;;shared ones.
-+               (define (push-many new-ws)
-+                  (unless (eq? new-ws shared)
-+                     (push-many (cdr new-ws))
-+                     (activate-winding! (car new-ws))))
-+
-+               ;;Do it.
-+               (pop-many)
-+               (push-many new-ws))))
-+
-+      ;;The definitions themselves.
-+      (eval
-+         `(define call-with-current-continuation
-+             ;;It internally uses the built-in call/cc, so capture it.
-+             ,(let ((old-c/cc call-with-current-continuation))
-+                 (lambda (func)
-+                    ;;Use old call/cc to get the continuation.
-+                    (old-c/cc
-+                       (lambda (continuation)
-+                          ;;Call func with not the continuation itself
-+                          ;;but a procedure that adjusts the active
-+                          ;;windings to what they were when we made
-+                          ;;this, and only then calls the
-+                          ;;continuation.
-+                          (func
-+                             (let ((current-ws *active-windings*))
-+                                (lambda (x)
-+                                   (set-active-windings! current-ws)
-+                                   (continuation x)))))))))
-+         outer-env)
-+      ;;We can't just say "define (dynamic-wind before thunk after)"
-+      ;;because the lambda it's defined to lives in this environment,
-+      ;;not in the global environment.
-+      (eval
-+         `(define dynamic-wind
-+             ,(lambda (before thunk after)
-+                 ;;Make a new winding
-+                 (activate-winding! (make-winding before after))
-+                 (let ((result (thunk)))
-+                    ;;Get rid of the new winding.
-+                    (deactivate-top-winding!)
-+                    ;;The return value is that of thunk.
-+                    result)))
-+         outer-env)))
-+
-+(define call/cc call-with-current-continuation)
-+
-+
-+;;;;; atom? and equal? written by a.k
-+
-+;;;; atom?
-+(define (atom? x)
-+  (not (pair? x)))
-+
-+;;;;    equal?
-+(define (equal? x y)
-+     (cond
-+          ((pair? x)
-+               (and (pair? y)
-+                    (equal? (car x) (car y))
-+                    (equal? (cdr x) (cdr y))))
-+          ((vector? x)
-+               (and (vector? y) (vector-equal? x y)))
-+          ((string? x)
-+               (and (string? y) (string=? x y)))
-+          (else (eqv? x y))))
-+
-+;;;; (do ((var init inc) ...) (endtest result ...) body ...)
-+;;
-+(macro do
-+  (lambda (do-macro)
-+    (apply (lambda (do vars endtest . body)
-+             (let ((do-loop (gensym)))
-+               `(letrec ((,do-loop
-+                           (lambda ,(map (lambda (x)
-+                                           (if (pair? x) (car x) x))
-+                                      `,vars)
-+                             (if ,(car endtest)
-+                               (begin ,@(cdr endtest))
-+                               (begin
-+                                 ,@body
-+                                 (,do-loop
-+                                   ,@(map (lambda (x)
-+                                            (cond
-+                                              ((not (pair? x)) x)
-+                                              ((< (length x) 3) (car x))
-+                                              (else (car (cdr (cdr x))))))
-+                                       `,vars)))))))
-+                  (,do-loop
-+                    ,@(map (lambda (x)
-+                             (if (and (pair? x) (cdr x))
-+                               (car (cdr x))
-+                               '()))
-+                        `,vars)))))
-+      do-macro)))
-+
-+;;;; generic-member
-+(define (generic-member cmp obj lst)
-+  (cond
-+    ((null? lst) #f)
-+    ((cmp obj (car lst)) lst)
-+    (else (generic-member cmp obj (cdr lst)))))
-+
-+(define (memq obj lst)
-+     (generic-member eq? obj lst))
-+(define (memv obj lst)
-+     (generic-member eqv? obj lst))
-+(define (member obj lst)
-+     (generic-member equal? obj lst))
-+
-+;;;; generic-assoc
-+(define (generic-assoc cmp obj alst)
-+     (cond
-+          ((null? alst) #f)
-+          ((cmp obj (caar alst)) (car alst))
-+          (else (generic-assoc cmp obj (cdr alst)))))
-+
-+(define (assq obj alst)
-+     (generic-assoc eq? obj alst))
-+(define (assv obj alst)
-+     (generic-assoc eqv? obj alst))
-+(define (assoc obj alst)
-+     (generic-assoc equal? obj alst))
-+
-+(define (acons x y z) (cons (cons x y) z))
-+
-+;;;; Handy for imperative programs
-+;;;; Used as: (define-with-return (foo x y) .... (return z) ...)
-+(macro (define-with-return form)
-+     `(define ,(cadr form)
-+          (call/cc (lambda (return) ,@(cddr form)))))
-+
-+;;;; Simple exception handling
-+;
-+;    Exceptions are caught as follows:
-+;
-+;         (catch (do-something to-recover and-return meaningful-value)
-+;              (if-something goes-wrong)
-+;              (with-these calls))
-+;
-+;    "Catch" establishes a scope spanning multiple call-frames
-+;    until another "catch" is encountered.
-+;
-+;    Exceptions are thrown with:
-+;
-+;         (throw "message")
-+;
-+;    If used outside a (catch ...), reverts to (error "message)
-+
-+(define *handlers* (list))
-+
-+(define (push-handler proc)
-+     (set! *handlers* (cons proc *handlers*)))
-+
-+(define (pop-handler)
-+     (let ((h (car *handlers*)))
-+          (set! *handlers* (cdr *handlers*))
-+          h))
-+
-+(define (more-handlers?)
-+     (pair? *handlers*))
-+
-+(define (throw . x)
-+     (if (more-handlers?)
-+          (apply (pop-handler))
-+          (apply error x)))
-+
-+(macro (catch form)
-+     (let ((label (gensym)))
-+          `(call/cc (lambda (exit)
-+               (push-handler (lambda () (exit ,(cadr form))))
-+               (let ((,label (begin ,@(cddr form))))
-+                    (pop-handler)
-+                    ,label)))))
-+
-+(define *error-hook* throw)
-+
-+
-+;;;;; Definition of MAKE-ENVIRONMENT, to be used with two-argument EVAL
-+
-+(macro (make-environment form)
-+     `(apply (lambda ()
-+               ,@(cdr form)
-+               (current-environment))))
-+
-+(define-macro (eval-polymorphic x . envl)
-+  (display envl)
-+  (let* ((env (if (null? envl) (current-environment) (eval (car envl))))
-+         (xval (eval x env)))
-+    (if (closure? xval)
-+      (make-closure (get-closure-code xval) env)
-+      xval)))
-+
-+; Redefine this if you install another package infrastructure
-+; Also redefine 'package'
-+(define *colon-hook* eval)
-+
-+;;;;; I/O
-+
-+(define (input-output-port? p)
-+     (and (input-port? p) (output-port? p)))
-+
-+(define (close-port p)
-+     (cond
-+          ((input-output-port? p) (close-input-port (close-output-port p)))
-+          ((input-port? p) (close-input-port p))
-+          ((output-port? p) (close-output-port p))
-+          (else (throw "Not a port" p))))
-+
-+(define (call-with-input-file s p)
-+     (let ((inport (open-input-file s)))
-+          (if (eq? inport #f)
-+               #f
-+               (let ((res (p inport)))
-+                    (close-input-port inport)
-+                    res))))
-+
-+(define (call-with-output-file s p)
-+     (let ((outport (open-output-file s)))
-+          (if (eq? outport #f)
-+               #f
-+               (let ((res (p outport)))
-+                    (close-output-port outport)
-+                    res))))
-+
-+(define (with-input-from-file s p)
-+     (let ((inport (open-input-file s)))
-+          (if (eq? inport #f)
-+               #f
-+               (let ((prev-inport (current-input-port)))
-+                    (set-input-port inport)
-+                    (let ((res (p)))
-+                         (close-input-port inport)
-+                         (set-input-port prev-inport)
-+                         res)))))
-+
-+(define (with-output-to-file s p)
-+     (let ((outport (open-output-file s)))
-+          (if (eq? outport #f)
-+               #f
-+               (let ((prev-outport (current-output-port)))
-+                    (set-output-port outport)
-+                    (let ((res (p)))
-+                         (close-output-port outport)
-+                         (set-output-port prev-outport)
-+                         res)))))
-+
-+(define (with-input-output-from-to-files si so p)
-+     (let ((inport (open-input-file si))
-+           (outport (open-input-file so)))
-+          (if (not (and inport outport))
-+               (begin
-+                    (close-input-port inport)
-+                    (close-output-port outport)
-+                    #f)
-+               (let ((prev-inport (current-input-port))
-+                     (prev-outport (current-output-port)))
-+                    (set-input-port inport)
-+                    (set-output-port outport)
-+                    (let ((res (p)))
-+                         (close-input-port inport)
-+                         (close-output-port outport)
-+                         (set-input-port prev-inport)
-+                         (set-output-port prev-outport)
-+                         res)))))
-+
-+; Random number generator (maximum cycle)
-+(define *seed* 1)
-+(define (random-next)
-+     (let* ((a 16807) (m 2147483647) (q (quotient m a)) (r (modulo m a)))
-+          (set! *seed*
-+               (-   (* a (- *seed*
-+                         (* (quotient *seed* q) q)))
-+                    (* (quotient *seed* q) r)))
-+          (if (< *seed* 0) (set! *seed* (+ *seed* m)))
-+          *seed*))
-+;; SRFI-0
-+;; COND-EXPAND
-+;; Implemented as a macro
-+(define *features* '(srfi-0))
-+
-+(define-macro (cond-expand . cond-action-list)
-+  (cond-expand-runtime cond-action-list))
-+
-+(define (cond-expand-runtime cond-action-list)
-+  (if (null? cond-action-list)
-+      #t
-+      (if (cond-eval (caar cond-action-list))
-+          `(begin ,@(cdar cond-action-list))
-+          (cond-expand-runtime (cdr cond-action-list)))))
-+
-+(define (cond-eval-and cond-list)
-+  (foldr (lambda (x y) (and (cond-eval x) (cond-eval y))) #t cond-list))
-+
-+(define (cond-eval-or cond-list)
-+  (foldr (lambda (x y) (or (cond-eval x) (cond-eval y))) #f cond-list))
-+
-+(define (cond-eval condition)
-+  (cond
-+    ((symbol? condition)
-+       (if (member condition *features*) #t #f))
-+    ((eq? condition #t) #t)
-+    ((eq? condition #f) #f)
-+    (else (case (car condition)
-+            ((and) (cond-eval-and (cdr condition)))
-+            ((or) (cond-eval-or (cdr condition)))
-+            ((not) (if (not (null? (cddr condition)))
-+                     (error "cond-expand : 'not' takes 1 argument")
-+                     (not (cond-eval (cadr condition)))))
-+            (else (error "cond-expand : unknown operator" (car condition)))))))
-+
-+(gc-verbose #f)
-diff --git a/bootshell/main.c b/bootshell/main.c
-new file mode 100644
-index 0000000..6c05a59
---- /dev/null
-+++ b/bootshell/main.c
-@@ -0,0 +1,248 @@
-+/* Standard startup-time command line parser
-+
-+   Copyright (C) 1995, 1996, 1997, 1998, 1999, 2001, 2007
-+     Free Software Foundation, Inc.
-+*/
-+#include <argp.h>
-+#include <assert.h>
-+#include <ctype.h>
-+#include <stdarg.h>
-+#include <stdio.h>
-+#include <stdlib.h>
-+#include <unistd.h>
-+#include <error.h>
-+#include <hurd.h>
-+#include <hurd/fshelp.h>
-+#include <device/device.h>
-+#include <version.h>
-+
-+#include "scheme.h"
-+#include "scheme-private.h"
-+
-+#include "bootshell.h"
-+#include "ffi.h"
-+
-+task_t bootscript_task;
-+task_t rootfs_server_task;
-+task_t exec_server_task;
-+
-+#define _HURD_RUNSYSTEM	"/hurd/runsystem.scm"
-+#define _BOOT_COMMAND "(boot)"
-+
-+char *multiboot_command_line;
-+char *boot_init_program;
-+boolean_t boot_pause;
-+char *boot_command = _BOOT_COMMAND;
-+char **global_argv;
-+boolean_t booted;
-+boolean_t interactive;
-+
-+scheme scm;
-+
-+/* We catch exceptions using this port. */
-+mach_port_t exception_port;
-+
-+mach_port_t console;
-+
-+mach_port_t portarray_template[INIT_PORT_MAX];
-+
-+const char *argp_program_version = STANDARD_HURD_VERSION (bootshell);
-+
-+#define OPT_HOST_PRIV_PORT	(-1)
-+#define OPT_DEVICE_MASTER_PORT	(-2)
-+#define OPT_BOOTSCRIPT_TASK	(-3)
-+#define OPT_ROOTFS_SERVER_TASK	(-4)
-+#define OPT_EXEC_SERVER_TASK	(-5)
-+#define OPT_BOOT_CMDLINE	(-6)
-+#define OPT_BOOT_COMMAND	(-7)
-+#define OPT_BOOT_INIT_PROGRAM	(-8)
-+#define OPT_BOOT_PAUSE		(-9)
-+
-+static const struct argp_option options[] =
-+{
-+  {"interactive", 'I', NULL, 0, "start interactive repl"},
-+  {0,0,0,0, "Boot options:", -2},
-+  {"multiboot-command-line", OPT_BOOT_CMDLINE, "ARGS", 0,
-+   "The multiboot kernel command line"},
-+  {"bootflags", 0, 0, OPTION_ALIAS|OPTION_HIDDEN},
-+  {"boot-debug-pause",  OPT_BOOT_PAUSE,	         NULL, 0,
-+   "Pause for keystroke before starting bootstrap programs"},
-+  {"boot-command",	 OPT_BOOT_COMMAND,	 "S-EXPRESSION", 0,
-+   "Command to run, default: " _BOOT_COMMAND},
-+  {"host-priv-port",     OPT_HOST_PRIV_PORT,     "PORT"},
-+  {"device-master-port", OPT_DEVICE_MASTER_PORT, "PORT"},
-+  {"bootscript-task",   OPT_BOOTSCRIPT_TASK,   "PORT"},
-+  {"rootfs-server-task",   OPT_ROOTFS_SERVER_TASK,   "PORT"},
-+  {"exec-server-task",   OPT_EXEC_SERVER_TASK,   "PORT"},
-+  {0}
-+};
-+
-+static error_t
-+parse_opt (int opt, char *arg, struct argp_state *state)
-+{
-+  switch (opt)
-+    {
-+      /* Boot options */
-+    case 'I':
-+      interactive = 1;
-+      break;
-+    case OPT_DEVICE_MASTER_PORT:
-+      _hurd_device_master = atoi (arg); break;
-+    case OPT_HOST_PRIV_PORT:
-+      _hurd_host_priv = atoi (arg); break;
-+    case OPT_BOOTSCRIPT_TASK:
-+      bootscript_task = atoi (arg); break;
-+    case OPT_ROOTFS_SERVER_TASK:
-+      rootfs_server_task = atoi (arg); break;
-+    case OPT_EXEC_SERVER_TASK:
-+      exec_server_task = atoi (arg); break;
-+    case OPT_BOOT_CMDLINE:
-+      multiboot_command_line = arg; break;
-+    case OPT_BOOT_INIT_PROGRAM:
-+      boot_init_program = arg; break;
-+    case OPT_BOOT_PAUSE:
-+      boot_pause = 1; break;
-+    case OPT_BOOT_COMMAND:
-+      boot_command = arg; break;
-+    case ARGP_KEY_END:
-+      global_argv = state->argv; break;
-+    default:
-+      return ARGP_ERR_UNKNOWN;
-+    case ARGP_KEY_INIT:
-+    case ARGP_KEY_SUCCESS:
-+    case ARGP_KEY_ERROR:
-+      break;
-+    }
-+  return 0;
-+}
-+
-+static const char doc[] =
-+  "Start and maintain hurd core servers and system run state";
-+
-+static const struct argp argp =
-+{ options, parse_opt, 0, doc };
-+
-+void
-+panic (const char *msg)
-+{
-+  mach_printf ("%s\n", msg);
-+  _exit (127);
-+}
-+
-+int
-+main (int argc, char **argv)
-+{
-+  error_t err;
-+  /* XXX */
-+  setenv ("TERM", "mach", 1);
-+  setenv ("COLS", "80", 1);
-+  setenv ("LINES", "25", 1);
-+
-+  argp_parse (&argp, argc, argv, /*ARGP_NO_ERRS|*/ARGP_IN_ORDER, 0, 0);
-+
-+  {
-+    mach_port_t proc = getproc ();
-+    if (MACH_PORT_VALID (proc))
-+      {
-+        booted = 1;
-+        err = mach_port_deallocate (mach_task_self (), proc);
-+        assert_perror (err);
-+      }
-+  }
-+
-+  if (! booted)
-+    {
-+      err = init_exception_handling ();
-+      if (err)
-+        error (1, err, "init_exception_handling");
-+    }
-+
-+  err = init_fs_server (); // XXX don't start automatically
-+  if (err)
-+    error (1, err, "init_fs_server");
-+
-+  if (MACH_PORT_VALID (_hurd_device_master))
-+    {
-+      err = device_open (_hurd_device_master, D_READ|D_WRITE,
-+                         "console", &console);
-+      if (err)
-+	panic ("Failed to open console.");
-+
-+      stdin = mach_open_devstream (console, "r");
-+      stdout = stderr = mach_open_devstream (console, "w");
-+      if (! stdin || ! stdout)
-+	panic ("Failed to open device stream.");
-+
-+      setvbuf (stdout, NULL, _IONBF, 0);
-+    }
-+
-+  if (! scheme_init (&scm))
-+    error (1, errno, "scheme_init");
-+
-+  scheme_set_input_port_file (&scm, stdin);
-+  scheme_set_output_port_file (&scm, stdout);
-+
-+  ffi_init (&scm);
-+
-+  load_embedded_script (&scm, init);
-+  load_embedded_script (&scm, boot);
-+  load_embedded_script (&scm, runsystem);
-+
-+  define_variable (&scm, bootscript_task);
-+  define_variable (&scm, rootfs_server_task);
-+  define_variable (&scm, exec_server_task);
-+  define_variable (&scm, boot_pause);
-+
-+  define_ (&scm, "host-priv",
-+           scm.vptr->mk_integer (&scm, _hurd_host_priv));
-+  define_ (&scm, "device-master",
-+           scm.vptr->mk_integer (&scm, _hurd_device_master));
-+
-+  define_variable_string (&scm, multiboot_command_line);
-+  define_variable_string (&scm, boot_init_program);
-+  define_variable_string (&scm, boot_command);
-+  define_variable (&scm, boot_pause);
-+  {
-+    char *argz = NULL;
-+    size_t argz_len = 0;
-+    err = argz_create (argv, &argz, &argz_len);
-+    assert_perror (err);
-+    define_ (&scm, "argv", ffi_argz2list (&scm, argz, argz_len, NULL));
-+  }
-+
-+  if (MACH_PORT_VALID (bootscript_task))
-+    {
-+      vm_size_t size;
-+      vm_prot_t prot, max_prot;
-+      mach_port_t obj;
-+      vm_offset_t addr = 0, offs;
-+      vm_inherit_t inh;
-+      int shared;
-+
-+      err =
-+	vm_region (bootscript_task, &addr, &size, &prot, &max_prot, &inh, &shared,
-+		   &obj, &offs);
-+      if (err)
-+	error (12, err, "vm_region");
-+
-+      vm_offset_t script;
-+      size_t count;
-+      err = vm_read (bootscript_task, addr, size, &script, &count);
-+      if (err)
-+	error (12, err, "vm_read");
-+      scheme_load_mem (&scm, (char *) script, (char *) script + size);
-+      if (scm.retcode) {
-+	fprintf (stderr, "Error: %d\n", scm.retcode);
-+      }
-+    }
-+
-+  if (! interactive)
-+    scheme_load_string (&scm, boot_command);
-+
-+  while (1)
-+    scheme_load_string (&scm, "(interactive-repl)");
-+
-+  /* Not reached.  */
-+  scheme_deinit(&scm);
-+  return 0;
-+}
-diff --git a/bootshell/mig-decls.h b/bootshell/mig-decls.h
-new file mode 100644
-index 0000000..120778d
---- /dev/null
-+++ b/bootshell/mig-decls.h
-@@ -0,0 +1,3 @@
-+#include <hurd.h>
-+
-+#define MIG_EOPNOTSUPP	({ abort (); EOPNOTSUPP; })
-diff --git a/bootshell/mig-mutate.h b/bootshell/mig-mutate.h
-new file mode 100644
-index 0000000..eadcbc9
---- /dev/null
-+++ b/bootshell/mig-mutate.h
-@@ -0,0 +1,27 @@
-+/*
-+   Copyright (C) 2014 Free Software Foundation, Inc.
-+   Written by Justus Winter.
-+
-+   This file is part of the GNU Hurd.
-+
-+   The GNU Hurd 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 2, or (at
-+   your option) any later version.
-+
-+   The GNU Hurd 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 the GNU Hurd.  If not, see <http://www.gnu.org/licenses/>.  */
-+
-+#define HURD_DEFAULT_PAYLOAD_TO_PORT	1
-+
-+#define FILE_IMPORTS					\
-+  import "mig-decls.h";
-+#define FSYS_IMPORTS					\
-+  import "mig-decls.h";
-+#define STARTUP_IMPORTS					\
-+  import "mig-decls.h";
-diff --git a/bootshell/opdefines.h b/bootshell/opdefines.h
-new file mode 100644
-index 0000000..ceb4d0e
---- /dev/null
-+++ b/bootshell/opdefines.h
-@@ -0,0 +1,195 @@
-+    _OP_DEF(opexe_0, "load",                           1,  1,       TST_STRING,                      OP_LOAD             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T0LVL            )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_T1LVL            )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_READ_INTERNAL    )
-+    _OP_DEF(opexe_0, "gensym",                         0,  0,       0,                               OP_GENSYM           )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_VALUEPRINT       )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_EVAL             )
-+#if USE_TRACING
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_EVAL        )
-+#endif
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E0ARGS           )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_E1ARGS           )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_APPLY            )
-+#if USE_TRACING
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_REAL_APPLY       )
-+    _OP_DEF(opexe_0, "tracing",                        1,  1,       TST_NATURAL,                     OP_TRACING          )
-+#endif
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DOMACRO          )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA           )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LAMBDA1          )
-+    _OP_DEF(opexe_0, "make-closure",                   1,  2,       TST_PAIR TST_ENVIRONMENT,        OP_MKCLOSURE        )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_QUOTE            )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF0             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_DEF1             )
-+    _OP_DEF(opexe_0, "defined?",                       1,  2,       TST_SYMBOL TST_ENVIRONMENT,      OP_DEFP             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_BEGIN            )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF0              )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_IF1              )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET0             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_SET1             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2             )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET0AST          )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET1AST          )
-+    _OP_DEF(opexe_0, 0,                                0,  0,       0,                               OP_LET2AST          )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET0REC          )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET1REC          )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_LET2REC          )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND0            )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_COND1            )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_DELAY            )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND0             )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_AND1             )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR0              )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_OR1              )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C0STREAM         )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_C1STREAM         )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO0           )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_MACRO1           )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE0            )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE1            )
-+    _OP_DEF(opexe_1, 0,                                0,  0,       0,                               OP_CASE2            )
-+    _OP_DEF(opexe_1, "eval",                           1,  2,       TST_ANY TST_ENVIRONMENT,         OP_PEVAL            )
-+    _OP_DEF(opexe_1, "apply",                          1,  INF_ARG, TST_NONE,                        OP_PAPPLY           )
-+    _OP_DEF(opexe_1, "call-with-current-continuation", 1,  1,       TST_NONE,                        OP_CONTINUATION     )
-+#if USE_MATH
-+    _OP_DEF(opexe_2, "inexact->exact",                 1,  1,       TST_NUMBER,                      OP_INEX2EX          )
-+    _OP_DEF(opexe_2, "exp",                            1,  1,       TST_NUMBER,                      OP_EXP              )
-+    _OP_DEF(opexe_2, "log",                            1,  1,       TST_NUMBER,                      OP_LOG              )
-+    _OP_DEF(opexe_2, "sin",                            1,  1,       TST_NUMBER,                      OP_SIN              )
-+    _OP_DEF(opexe_2, "cos",                            1,  1,       TST_NUMBER,                      OP_COS              )
-+    _OP_DEF(opexe_2, "tan",                            1,  1,       TST_NUMBER,                      OP_TAN              )
-+    _OP_DEF(opexe_2, "asin",                           1,  1,       TST_NUMBER,                      OP_ASIN             )
-+    _OP_DEF(opexe_2, "acos",                           1,  1,       TST_NUMBER,                      OP_ACOS             )
-+    _OP_DEF(opexe_2, "atan",                           1,  2,       TST_NUMBER,                      OP_ATAN             )
-+    _OP_DEF(opexe_2, "sqrt",                           1,  1,       TST_NUMBER,                      OP_SQRT             )
-+    _OP_DEF(opexe_2, "expt",                           2,  2,       TST_NUMBER,                      OP_EXPT             )
-+    _OP_DEF(opexe_2, "floor",                          1,  1,       TST_NUMBER,                      OP_FLOOR            )
-+    _OP_DEF(opexe_2, "ceiling",                        1,  1,       TST_NUMBER,                      OP_CEILING          )
-+    _OP_DEF(opexe_2, "truncate",                       1,  1,       TST_NUMBER,                      OP_TRUNCATE         )
-+    _OP_DEF(opexe_2, "round",                          1,  1,       TST_NUMBER,                      OP_ROUND            )
-+#endif
-+    _OP_DEF(opexe_2, "+",                              0,  INF_ARG, TST_NUMBER,                      OP_ADD              )
-+    _OP_DEF(opexe_2, "-",                              1,  INF_ARG, TST_NUMBER,                      OP_SUB              )
-+    _OP_DEF(opexe_2, "*",                              0,  INF_ARG, TST_NUMBER,                      OP_MUL              )
-+    _OP_DEF(opexe_2, "/",                              1,  INF_ARG, TST_NUMBER,                      OP_DIV              )
-+    _OP_DEF(opexe_2, "quotient",                       1,  INF_ARG, TST_INTEGER,                     OP_INTDIV           )
-+    _OP_DEF(opexe_2, "remainder",                      2,  2,       TST_INTEGER,                     OP_REM              )
-+    _OP_DEF(opexe_2, "modulo",                         2,  2,       TST_INTEGER,                     OP_MOD              )
-+    _OP_DEF(opexe_2, "car",                            1,  1,       TST_PAIR,                        OP_CAR              )
-+    _OP_DEF(opexe_2, "cdr",                            1,  1,       TST_PAIR,                        OP_CDR              )
-+    _OP_DEF(opexe_2, "cons",                           2,  2,       TST_NONE,                        OP_CONS             )
-+    _OP_DEF(opexe_2, "set-car!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCAR           )
-+    _OP_DEF(opexe_2, "set-cdr!",                       2,  2,       TST_PAIR TST_ANY,                OP_SETCDR           )
-+    _OP_DEF(opexe_2, "char->integer",                  1,  1,       TST_CHAR,                        OP_CHAR2INT         )
-+    _OP_DEF(opexe_2, "integer->char",                  1,  1,       TST_NATURAL,                     OP_INT2CHAR         )
-+    _OP_DEF(opexe_2, "char-upcase",                    1,  1,       TST_CHAR,                        OP_CHARUPCASE       )
-+    _OP_DEF(opexe_2, "char-downcase",                  1,  1,       TST_CHAR,                        OP_CHARDNCASE       )
-+    _OP_DEF(opexe_2, "symbol->string",                 1,  1,       TST_SYMBOL,                      OP_SYM2STR          )
-+    _OP_DEF(opexe_2, "atom->string",                   1,  2,       TST_ANY TST_NATURAL,             OP_ATOM2STR         )
-+    _OP_DEF(opexe_2, "string->symbol",                 1,  1,       TST_STRING,                      OP_STR2SYM          )
-+    _OP_DEF(opexe_2, "string->atom",                   1,  2,       TST_STRING TST_NATURAL,          OP_STR2ATOM         )
-+    _OP_DEF(opexe_2, "make-string",                    1,  2,       TST_NATURAL TST_CHAR,            OP_MKSTRING         )
-+    _OP_DEF(opexe_2, "string-length",                  1,  1,       TST_STRING,                      OP_STRLEN           )
-+    _OP_DEF(opexe_2, "string-ref",                     2,  2,       TST_STRING TST_NATURAL,          OP_STRREF           )
-+    _OP_DEF(opexe_2, "string-set!",                    3,  3,       TST_STRING TST_NATURAL TST_CHAR, OP_STRSET           )
-+    _OP_DEF(opexe_2, "string-append",                  0,  INF_ARG, TST_STRING,                      OP_STRAPPEND        )
-+    _OP_DEF(opexe_2, "substring",                      2,  3,       TST_STRING TST_NATURAL,          OP_SUBSTR           )
-+    _OP_DEF(opexe_2, "vector",                         0,  INF_ARG, TST_NONE,                        OP_VECTOR           )
-+    _OP_DEF(opexe_2, "make-vector",                    1,  2,       TST_NATURAL TST_ANY,             OP_MKVECTOR         )
-+    _OP_DEF(opexe_2, "vector-length",                  1,  1,       TST_VECTOR,                      OP_VECLEN           )
-+    _OP_DEF(opexe_2, "vector-ref",                     2,  2,       TST_VECTOR TST_NATURAL,          OP_VECREF           )
-+    _OP_DEF(opexe_2, "vector-set!",                    3,  3,       TST_VECTOR TST_NATURAL TST_ANY,  OP_VECSET           )
-+    _OP_DEF(opexe_3, "not",                            1,  1,       TST_NONE,                        OP_NOT              )
-+    _OP_DEF(opexe_3, "boolean?",                       1,  1,       TST_NONE,                        OP_BOOLP            )
-+    _OP_DEF(opexe_3, "eof-object?",                    1,  1,       TST_NONE,                        OP_EOFOBJP          )
-+    _OP_DEF(opexe_3, "null?",                          1,  1,       TST_NONE,                        OP_NULLP            )
-+    _OP_DEF(opexe_3, "=",                              2,  INF_ARG, TST_NUMBER,                      OP_NUMEQ            )
-+    _OP_DEF(opexe_3, "<",                              2,  INF_ARG, TST_NUMBER,                      OP_LESS             )
-+    _OP_DEF(opexe_3, ">",                              2,  INF_ARG, TST_NUMBER,                      OP_GRE              )
-+    _OP_DEF(opexe_3, "<=",                             2,  INF_ARG, TST_NUMBER,                      OP_LEQ              )
-+    _OP_DEF(opexe_3, ">=",                             2,  INF_ARG, TST_NUMBER,                      OP_GEQ              )
-+    _OP_DEF(opexe_3, "symbol?",                        1,  1,       TST_ANY,                         OP_SYMBOLP          )
-+    _OP_DEF(opexe_3, "number?",                        1,  1,       TST_ANY,                         OP_NUMBERP          )
-+    _OP_DEF(opexe_3, "string?",                        1,  1,       TST_ANY,                         OP_STRINGP          )
-+    _OP_DEF(opexe_3, "integer?",                       1,  1,       TST_ANY,                         OP_INTEGERP         )
-+    _OP_DEF(opexe_3, "real?",                          1,  1,       TST_ANY,                         OP_REALP            )
-+    _OP_DEF(opexe_3, "char?",                          1,  1,       TST_ANY,                         OP_CHARP            )
-+#if USE_CHAR_CLASSIFIERS
-+    _OP_DEF(opexe_3, "char-alphabetic?",               1,  1,       TST_CHAR,                        OP_CHARAP           )
-+    _OP_DEF(opexe_3, "char-numeric?",                  1,  1,       TST_CHAR,                        OP_CHARNP           )
-+    _OP_DEF(opexe_3, "char-whitespace?",               1,  1,       TST_CHAR,                        OP_CHARWP           )
-+    _OP_DEF(opexe_3, "char-upper-case?",               1,  1,       TST_CHAR,                        OP_CHARUP           )
-+    _OP_DEF(opexe_3, "char-lower-case?",               1,  1,       TST_CHAR,                        OP_CHARLP           )
-+#endif
-+    _OP_DEF(opexe_3, "port?",                          1,  1,       TST_ANY,                         OP_PORTP            )
-+    _OP_DEF(opexe_3, "input-port?",                    1,  1,       TST_ANY,                         OP_INPORTP          )
-+    _OP_DEF(opexe_3, "output-port?",                   1,  1,       TST_ANY,                         OP_OUTPORTP         )
-+    _OP_DEF(opexe_3, "procedure?",                     1,  1,       TST_ANY,                         OP_PROCP            )
-+    _OP_DEF(opexe_3, "pair?",                          1,  1,       TST_ANY,                         OP_PAIRP            )
-+    _OP_DEF(opexe_3, "list?",                          1,  1,       TST_ANY,                         OP_LISTP            )
-+    _OP_DEF(opexe_3, "environment?",                   1,  1,       TST_ANY,                         OP_ENVP             )
-+    _OP_DEF(opexe_3, "vector?",                        1,  1,       TST_ANY,                         OP_VECTORP          )
-+    _OP_DEF(opexe_3, "eq?",                            2,  2,       TST_ANY,                         OP_EQ               )
-+    _OP_DEF(opexe_3, "eqv?",                           2,  2,       TST_ANY,                         OP_EQV              )
-+    _OP_DEF(opexe_4, "force",                          1,  1,       TST_ANY,                         OP_FORCE            )
-+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_SAVE_FORCED      )
-+    _OP_DEF(opexe_4, "write",                          1,  2,       TST_ANY TST_OUTPORT,             OP_WRITE            )
-+    _OP_DEF(opexe_4, "write-char",                     1,  2,       TST_CHAR TST_OUTPORT,            OP_WRITE_CHAR       )
-+    _OP_DEF(opexe_4, "display",                        1,  2,       TST_ANY TST_OUTPORT,             OP_DISPLAY          )
-+    _OP_DEF(opexe_4, "newline",                        0,  1,       TST_OUTPORT,                     OP_NEWLINE          )
-+    _OP_DEF(opexe_4, "error",                          1,  INF_ARG, TST_NONE,                        OP_ERR0             )
-+    _OP_DEF(opexe_4, 0,                                0,  0,       0,                               OP_ERR1             )
-+    _OP_DEF(opexe_4, "reverse",                        1,  1,       TST_LIST,                        OP_REVERSE          )
-+    _OP_DEF(opexe_4, "list*",                          1,  INF_ARG, TST_NONE,                        OP_LIST_STAR        )
-+    _OP_DEF(opexe_4, "append",                         0,  INF_ARG, TST_NONE,                        OP_APPEND           )
-+#if USE_PLIST
-+    _OP_DEF(opexe_4, "put",                            3,  3,       TST_NONE,                        OP_PUT              )
-+    _OP_DEF(opexe_4, "get",                            2,  2,       TST_NONE,                        OP_GET              )
-+#endif
-+    _OP_DEF(opexe_4, "quit",                           0,  1,       TST_NUMBER,                      OP_QUIT             )
-+    _OP_DEF(opexe_4, "gc",                             0,  0,       0,                               OP_GC               )
-+    _OP_DEF(opexe_4, "gc-verbose",                     0,  1,       TST_NONE,                        OP_GCVERB           )
-+    _OP_DEF(opexe_4, "new-segment",                    0,  1,       TST_NUMBER,                      OP_NEWSEGMENT       )
-+    _OP_DEF(opexe_4, "oblist",                         0,  0,       0,                               OP_OBLIST           )
-+    _OP_DEF(opexe_4, "current-input-port",             0,  0,       0,                               OP_CURR_INPORT      )
-+    _OP_DEF(opexe_4, "current-output-port",            0,  0,       0,                               OP_CURR_OUTPORT     )
-+    _OP_DEF(opexe_4, "open-input-file",                1,  1,       TST_STRING,                      OP_OPEN_INFILE      )
-+    _OP_DEF(opexe_4, "open-output-file",               1,  1,       TST_STRING,                      OP_OPEN_OUTFILE     )
-+    _OP_DEF(opexe_4, "open-input-output-file",         1,  1,       TST_STRING,                      OP_OPEN_INOUTFILE   )
-+#if USE_STRING_PORTS
-+    _OP_DEF(opexe_4, "open-input-string",              1,  1,       TST_STRING,                      OP_OPEN_INSTRING    )
-+    _OP_DEF(opexe_4, "open-input-output-string",       1,  1,       TST_STRING,                      OP_OPEN_INOUTSTRING )
-+    _OP_DEF(opexe_4, "open-output-string",             0,  1,       TST_STRING,                      OP_OPEN_OUTSTRING   )
-+    _OP_DEF(opexe_4, "get-output-string",              1,  1,       TST_OUTPORT,                     OP_GET_OUTSTRING    )
-+#endif
-+    _OP_DEF(opexe_4, "close-input-port",               1,  1,       TST_INPORT,                      OP_CLOSE_INPORT     )
-+    _OP_DEF(opexe_4, "close-output-port",              1,  1,       TST_OUTPORT,                     OP_CLOSE_OUTPORT    )
-+    _OP_DEF(opexe_4, "interaction-environment",        0,  0,       0,                               OP_INT_ENV          )
-+    _OP_DEF(opexe_4, "current-environment",            0,  0,       0,                               OP_CURR_ENV         )
-+    _OP_DEF(opexe_5, "read",                           0,  1,       TST_INPORT,                      OP_READ             )
-+    _OP_DEF(opexe_5, "read-char",                      0,  1,       TST_INPORT,                      OP_READ_CHAR        )
-+    _OP_DEF(opexe_5, "peek-char",                      0,  1,       TST_INPORT,                      OP_PEEK_CHAR        )
-+    _OP_DEF(opexe_5, "char-ready?",                    0,  1,       TST_INPORT,                      OP_CHAR_READY       )
-+    _OP_DEF(opexe_5, "set-input-port",                 1,  1,       TST_INPORT,                      OP_SET_INPORT       )
-+    _OP_DEF(opexe_5, "set-output-port",                1,  1,       TST_OUTPORT,                     OP_SET_OUTPORT      )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDSEXPR          )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDLIST           )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDDOT            )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQUOTE          )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTE         )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDQQUOTEVEC      )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUNQUOTE        )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDUQTSP          )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_RDVEC            )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P0LIST           )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_P1LIST           )
-+    _OP_DEF(opexe_5, 0,                                0,  0,       0,                               OP_PVECFROM         )
-+    _OP_DEF(opexe_6, "length",                         1,  1,       TST_LIST,                        OP_LIST_LENGTH      )
-+    _OP_DEF(opexe_6, "assq",                           2,  2,       TST_NONE,                        OP_ASSQ             )
-+    _OP_DEF(opexe_6, "get-closure-code",               1,  1,       TST_NONE,                        OP_GET_CLOSURE      )
-+    _OP_DEF(opexe_6, "closure?",                       1,  1,       TST_NONE,                        OP_CLOSUREP         )
-+    _OP_DEF(opexe_6, "macro?",                         1,  1,       TST_NONE,                        OP_MACROP           )
-+#undef _OP_DEF
-diff --git a/bootshell/runsystem.scm b/bootshell/runsystem.scm
-new file mode 100644
-index 0000000..4e71dd2
---- /dev/null
-+++ b/bootshell/runsystem.scm
-@@ -0,0 +1,196 @@
-+;; The Hurd server bootstrap.
-+;;
-+;; XXX license, how to modify
-+
-+(define timeout 1000) ; 1 second
-+
-+(define (pause)
-+  (if (= 1 boot-pause) (prompt "Press enter to continue...")))
-+
-+;; Tests if a device with the given NAME exists.
-+(define (devprobe? name)
-+  (letport ((device (catch MACH_PORT_NULL
-+			   (device-open device-master D_READ name))))
-+    (mach-port-valid? device)))
-+
-+;; Insert RIGHT into TASK.  Returns the name of RIGHT in TASK.
-+(define (task-insert-send-right task right)
-+  (let loop ((name 1))
-+    (catch (loop (+ name 1))
-+	   (mach-port-insert-right task name right MACH_MSG_TYPE_COPY_SEND)
-+	   name)))
-+
-+;; Inserts RIGHT into TASK and returns a command line argument OPTION
-+;; with the value set to the name of RIGHT in TASK.
-+(define (make-arg option task right)
-+  (string-append "--" option "="
-+		 (number->string (task-insert-send-right task right))))
-+
-+;; Returns a function that can be passed to `bootstrap-translator' to
-+;; resume a translator loaded by the traditional bootscript mechanism.
-+(define (resume-translator task args)
-+  (lambda (bootstrap)
-+    (task-set-exception-port task (make-send-right exception-port))
-+    (task-set-bootstrap-port task bootstrap)
-+    (pause)
-+    (task-resume task)
-+    (handle-exec-startup bootstrap args timeout)
-+    task))
-+
-+;; Returns a function that can be passed to `bootstrap-translator' to
-+;; start a translator that is loaded from a disk.
-+(define (start-translator task argv)
-+  (lambda (bootstrap)
-+    (letport ((proc (getproc)))
-+      (pause)
-+      (_exec (file-name-lookup (car argv) O_EXEC 0) task argv bootstrap)
-+      (if (mach-port-valid? proc)
-+	  (let ((child-proc (proc->task->proc proc task)))
-+	    (proc->task->child! proc task)
-+	    (proc->mark-exec! child-proc)
-+	    (proc->mark-important! child-proc))))))
-+
-+;; Bootstraps a translator using the fsys protocol.
-+(define (bootstrap-translator prepare-task realnode)
-+  (let* ((bootstrap
-+	  (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE))
-+	 (task
-+	  (prepare-task (make-send-right bootstrap))))
-+    (handle-fsys-startup bootstrap realnode MACH_MSG_TYPE_COPY_SEND timeout)))
-+
-+;; Bootstraps the proc server using the startup protocol.
-+(define (bootstrap-proc prepare-task)
-+  (let* ((bootstrap
-+	  (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE))
-+	 (task
-+	  (prepare-task (make-send-right bootstrap))))
-+    (handle-startup-procinit bootstrap timeout)))
-+
-+;; Bootstraps the auth server using the startup protocol.
-+(define (bootstrap-auth prepare-task)
-+  (let* ((bootstrap
-+	  (mach-port-allocate mach-task-self MACH_PORT_RIGHT_RECEIVE))
-+	 (task
-+	  (prepare-task (make-send-right bootstrap))))
-+    (handle-startup-authinit bootstrap timeout)))
-+
-+;; Bootstraps a translator using the fsys protocol and installs it as
-+;; root filesystem.
-+(define (bind-root prepare-task)
-+  (let ((control
-+	 (bootstrap-translator prepare-task (make-send-right rootnode))))
-+    (_bind-root control rootnode)
-+    control))
-+
-+;; Bootstraps a translator using the fsys protocol and installs it as
-+;; active translator for the node PATH.
-+(define (bind path prepare-task)
-+  (letport ((realnode (file-name-lookup path O_NOTRANS 438))
-+	    (control (bootstrap-translator prepare-task realnode)))
-+	   (set-active-translator path control)
-+	   (copy-send-right control)))
-+
-+;; We start servers when the proc server is not yet around.  Once the
-+;; proc server is available, we use this function to update its state
-+;; related to TASK.
-+(define (fixup-task task)
-+  (letport ((myproc (getproc))
-+	    (p (proc->task->proc myproc task)))
-+    (proc->task->child! myproc task)
-+    (proc->mark-important! p)
-+    (proc->mark-exec! p)))
-+
-+(define (bootstrap rootfs-args exec-args)
-+  (log "Hurd server bootstrap: ")
-+
-+  (log "rootfs ")
-+  (let ((rootfs-control (bind-root (resume-translator rootfs-server-task
-+						      rootfs-args)))
-+	(startup-control (mach-port-allocate mach-task-self
-+					     MACH_PORT_RIGHT_RECEIVE))
-+	(proc-task (task-create mach-task-self 0))
-+	(auth-task (task-create mach-task-self 0))
-+	;; Projections for the cookies returned by bootstrap-*.
-+	(:reply car) (:replyPoly cadr) (:server caddr))
-+    (start-handling-early-startup startup-control)
-+    (set-active-translator "/servers/startup"
-+			   (make-send-right startup-control))
-+    (log "exec ")
-+    (bind "/servers/exec" (resume-translator exec-server-task exec-args))
-+
-+    ;; Starting proc and auth is tricky, we need to do it simultaneously.
-+    (let ((pc (bootstrap-proc (start-translator proc-task '("/hurd/proc"))))
-+	  (ac (bootstrap-auth (start-translator auth-task '("/hurd/auth")))))
-+      (log "proc ")
-+      (startup-procinit-reply (:reply pc) (:replyPoly pc) ESUCCESS
-+			      mach-task-self (:server ac)
-+			      host-priv device-master)
-+      (bind-proc (:server pc))
-+
-+      ;; Declare that these tasks are our children, and fix them up.
-+      (map fixup-task (list rootfs-server-task exec-server-task
-+			    proc-task auth-task))
-+
-+      (log "auth ")
-+      (startup-authinit-reply (:reply ac) (:replyPoly ac) ESUCCESS
-+			      (proc->task->proc (:server pc) auth-task))
-+      (bind-auth (:server ac))
-+
-+      ;; Give the rootfs its proc and auth port.
-+      (fsys-init rootfs-control
-+		 (proc->task->proc (:server pc) rootfs-server-task)
-+		 (:server ac))
-+
-+      ;; Supply the proc server with a standard template.
-+      (proc->auth->set-std-execdata! (:server pc) (:server ac))
-+
-+      (mach-port-deallocate mach-task-self (:server pc))
-+      (mach-port-deallocate mach-task-self (:server ac))))
-+
-+  (log "console ")
-+  (bind "/dev/console"
-+	(start-translator (task-create mach-task-self 0)
-+			  '("/hurd/term" "/dev/console" "device" "console")))
-+
-+  (letport ((term (file-name-lookup "/dev/console" O_RDWR 0)))
-+	   (bind-term term))
-+
-+  ;; If we made it this far, we can use libreadline!
-+  (enable-readline)
-+
-+  ;; The standalone startup server watches essential servers, and
-+  ;; handles the system shutdown.
-+  (log "startup ")
-+  (bind "/servers/startup"
-+	(start-translator (task-create mach-task-self 0)
-+			  '("/hurd/startup-standalone")))
-+
-+  ;; Now that we have startup, register all servers to it.
-+  (letport
-+   ((startup (file-name-lookup "/servers/startup" 0 0)))
-+   (let ((:port car) (:name cdr)) ;; Projections.
-+     ;; We are essential.
-+     (startup-essential-task startup mach-task-self MACH_PORT_NULL
-+			     "bootshell" host-priv)
-+     (map (lambda (c)
-+	    (startup-essential-task startup (:port c) MACH_PORT_NULL
-+				    (:name c) host-priv))
-+	  (get-essential-tasks))
-+     (map (lambda (c)
-+	    (startup-request-notification startup (:port c) (:name c)))
-+	  (get-registered-tasks))))
-+
-+  (log "pflocal ")
-+  (bind "/servers/socket/1"
-+	(start-translator (task-create mach-task-self 0)
-+			  '("/hurd/pflocal")))
-+
-+  (log "done.\n"))
-+
-+(define (boot)
-+  (catch (panic "Hurd bootstrap failed: " (car last-exception) "\n")
-+	 (bootstrap '() '()))
-+
-+  (shell (lambda (prefix)
-+	   (prompt-append-prefix
-+	    (string-append "runsystem@" (hostname) " " (getcwd) " ") prefix))))
-diff --git a/bootshell/scheme-config.h b/bootshell/scheme-config.h
-new file mode 100644
-index 0000000..890fb3e
---- /dev/null
-+++ b/bootshell/scheme-config.h
-@@ -0,0 +1,12 @@
-+#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		0
-+#define USE_DL			0
-+#define USE_PLIST		0
-+#define USE_INTERFACE		1
-+#define SHOW_ERROR_LINE		1
-diff --git a/bootshell/scheme-private.h b/bootshell/scheme-private.h
-new file mode 100644
-index 0000000..3395328
---- /dev/null
-+++ b/bootshell/scheme-private.h
-@@ -0,0 +1,210 @@
-+/* scheme-private.h */
-+
-+#ifndef _SCHEME_PRIVATE_H
-+#define _SCHEME_PRIVATE_H
-+
-+#include "scheme.h"
-+/*------------------ Ugly internals -----------------------------------*/
-+/*------------------ Of interest only to FFI users --------------------*/
-+
-+#ifdef __cplusplus
-+extern "C" {
-+#endif
-+
-+enum scheme_port_kind {
-+  port_free=0,
-+  port_file=1,
-+  port_string=2,
-+  port_srfi6=4,
-+  port_input=16,
-+  port_output=32,
-+  port_saw_EOF=64
-+};
-+
-+typedef struct port {
-+  unsigned char kind;
-+  union {
-+    struct {
-+      FILE *file;
-+      int closeit;
-+#if SHOW_ERROR_LINE
-+      int curr_line;
-+      char *filename;
-+#endif
-+    } stdio;
-+    struct {
-+      char *start;
-+      char *past_the_end;
-+      char *curr;
-+    } string;
-+  } rep;
-+} port;
-+
-+/* cell structure */
-+struct cell {
-+  unsigned int _flag;
-+  union {
-+    struct {
-+      char   *_svalue;
-+      int   _length;
-+    } _string;
-+    num _number;
-+    port *_port;
-+    foreign_func _ff;
-+    struct {
-+      struct cell *_car;
-+      struct cell *_cdr;
-+    } _cons;
-+  } _object;
-+};
-+
-+struct scheme {
-+/* arrays for segments */
-+func_alloc malloc;
-+func_dealloc free;
-+
-+/* return code */
-+int retcode;
-+int tracing;
-+
-+
-+#define CELL_SEGSIZE    5000  /* # of cells in one segment */
-+#define CELL_NSEGMENT   10    /* # of segments for cells */
-+char *alloc_seg[CELL_NSEGMENT];
-+pointer cell_seg[CELL_NSEGMENT];
-+int     last_cell_seg;
-+
-+/* We use 4 registers. */
-+pointer args;            /* register for arguments of function */
-+pointer envir;           /* stack register for current environment */
-+pointer code;            /* register for current code */
-+pointer dump;            /* stack register for next evaluation */
-+
-+int interactive_repl;    /* are we in an interactive REPL? */
-+
-+struct cell _sink;
-+pointer sink;            /* when mem. alloc. fails */
-+struct cell _NIL;
-+pointer NIL;             /* special cell representing empty cell */
-+struct cell _HASHT;
-+pointer T;               /* special cell representing #t */
-+struct cell _HASHF;
-+pointer F;               /* special cell representing #f */
-+struct cell _EOF_OBJ;
-+pointer EOF_OBJ;         /* special cell representing end-of-file object */
-+pointer oblist;          /* pointer to symbol table */
-+pointer global_env;      /* pointer to global environment */
-+pointer c_nest;          /* stack for nested calls from C */
-+
-+/* global pointers to special symbols */
-+pointer LAMBDA;               /* pointer to syntax lambda */
-+pointer QUOTE;           /* pointer to syntax quote */
-+
-+pointer QQUOTE;               /* pointer to symbol quasiquote */
-+pointer UNQUOTE;         /* pointer to symbol unquote */
-+pointer UNQUOTESP;       /* pointer to symbol unquote-splicing */
-+pointer FEED_TO;         /* => */
-+pointer COLON_HOOK;      /* *colon-hook* */
-+pointer ERROR_HOOK;      /* *error-hook* */
-+pointer SHARP_HOOK;  /* *sharp-hook* */
-+pointer COMPILE_HOOK;  /* *compile-hook* */
-+
-+pointer free_cell;       /* pointer to top of free cells */
-+long    fcells;          /* # of free cells */
-+
-+pointer inport;
-+pointer outport;
-+pointer save_inport;
-+pointer loadport;
-+
-+#define MAXFIL 64
-+port load_stack[MAXFIL];     /* Stack of open files for port -1 (LOADing) */
-+int nesting_stack[MAXFIL];
-+int file_i;
-+int nesting;
-+
-+char    gc_verbose;      /* if gc_verbose is not zero, print gc status */
-+char    no_memory;       /* Whether mem. alloc. has failed */
-+
-+#define LINESIZE 1024
-+char    linebuff[LINESIZE];
-+#define STRBUFFSIZE 256
-+char    strbuff[STRBUFFSIZE];
-+
-+FILE *tmpfp;
-+int tok;
-+int print_flag;
-+pointer value;
-+int op;
-+
-+void *ext_data;     /* For the benefit of foreign functions */
-+long gensym_cnt;
-+
-+struct scheme_interface *vptr;
-+void *dump_base;    /* pointer to base of allocated dump stack */
-+int dump_size;      /* number of frames allocated for dump stack */
-+};
-+
-+/* operator code */
-+enum scheme_opcodes {
-+#define _OP_DEF(A,B,C,D,E,OP) OP,
-+#include "opdefines.h"
-+  OP_MAXDEFINED
-+};
-+
-+
-+#define cons(sc,a,b) _cons(sc,a,b,0)
-+#define immutable_cons(sc,a,b) _cons(sc,a,b,1)
-+
-+int is_string(pointer p);
-+char *string_value(pointer p);
-+int is_number(pointer p);
-+num nvalue(pointer p);
-+long ivalue(pointer p);
-+double rvalue(pointer p);
-+int is_integer(pointer p);
-+int is_real(pointer p);
-+int is_character(pointer p);
-+long charvalue(pointer p);
-+int is_vector(pointer p);
-+
-+int is_port(pointer p);
-+
-+int is_pair(pointer p);
-+pointer pair_car(pointer p);
-+pointer pair_cdr(pointer p);
-+pointer set_car(pointer p, pointer q);
-+pointer set_cdr(pointer p, pointer q);
-+
-+int is_symbol(pointer p);
-+char *symname(pointer p);
-+int hasprop(pointer p);
-+
-+int is_syntax(pointer p);
-+int is_proc(pointer p);
-+int is_foreign(pointer p);
-+char *syntaxname(pointer p);
-+int is_closure(pointer p);
-+#ifdef USE_MACRO
-+int is_macro(pointer p);
-+#endif
-+pointer closure_code(pointer p);
-+pointer closure_env(pointer p);
-+
-+int is_continuation(pointer p);
-+int is_promise(pointer p);
-+int is_environment(pointer p);
-+int is_immutable(pointer p);
-+void setimmutable(pointer p);
-+
-+#ifdef __cplusplus
-+}
-+#endif
-+
-+#endif
-+
-+/*
-+Local variables:
-+c-file-style: "k&r"
-+End:
-+*/
-diff --git a/bootshell/scheme.c b/bootshell/scheme.c
-new file mode 100644
-index 0000000..5ca5641
---- /dev/null
-+++ b/bootshell/scheme.c
-@@ -0,0 +1,5075 @@
-+/* 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)
-+ *
-+ */
-+
-+#define _SCHEME_SOURCE
-+#include "scheme-private.h"
-+#ifndef WIN32
-+# include <unistd.h>
-+#endif
-+#ifdef WIN32
-+#define snprintf _snprintf
-+#endif
-+#if USE_DL
-+# include "dynload.h"
-+#endif
-+#if USE_MATH
-+# include <math.h>
-+#endif
-+
-+#include <limits.h>
-+#include <float.h>
-+#include <ctype.h>
-+
-+#if USE_STRCASECMP
-+#include <strings.h>
-+# 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 <string.h>
-+#include <stdlib.h>
-+
-+#ifdef __APPLE__
-+static int stricmp(const char *s1, const char *s2)
-+{
-+  unsigned char c1, c2;
-+  do {
-+    c1 = tolower(*s1);
-+    c2 = tolower(*s2);
-+    if (c1 < c2)
-+      return -1;
-+    else if (c1 > c2)
-+      return 1;
-+    s1++, s2++;
-+  } while (c1 != 0);
-+  return 0;
-+}
-+#endif /* __APPLE__ */
-+
-+#if USE_STRLWR
-+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
-+
-+enum scheme_types {
-+  T_STRING=1,
-+  T_NUMBER=2,
-+  T_SYMBOL=3,
-+  T_PROC=4,
-+  T_PAIR=5,
-+  T_CLOSURE=6,
-+  T_CONTINUATION=7,
-+  T_FOREIGN=8,
-+  T_CHARACTER=9,
-+  T_PORT=10,
-+  T_VECTOR=11,
-+  T_MACRO=12,
-+  T_PROMISE=13,
-+  T_ENVIRONMENT=14,
-+  T_LAST_SYSTEM_TYPE=14
-+};
-+
-+/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
-+#define ADJ 32
-+#define TYPE_BITS 5
-+#define T_MASKTYPE      31    /* 0000000000011111 */
-+#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 num num_zero;
-+static num num_one;
-+
-+/* macros for cell operations */
-+#define typeflag(p)      ((p)->_flag)
-+#define type(p)          (typeflag(p)&T_MASKTYPE)
-+
-+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); }
-+INTERFACE static void fill_vector(pointer vec, pointer obj);
-+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 (typeflag(p)&T_SYMBOL); }
-+#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(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)
-+
-+/* 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
-+
-+#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_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]={
-+ "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(stricmp(name,charnames[i])==0) {
-+          *pc=i;
-+          return 1;
-+     }
-+  }
-+  if(stricmp(name,"del")==0) {
-+     *pc=127;
-+     return 1;
-+  }
-+  return 0;
-+}
-+
-+#endif
-+
-+static int file_push(scheme *sc, const char *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 void 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 a);
-+static pointer reverse_in_place(scheme *sc, pointer term, pointer list);
-+static pointer revappend(scheme *sc, pointer a, pointer b);
-+static void dump_stack_mark(scheme *);
-+static pointer opexe_0(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_1(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_2(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_3(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_4(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_5(scheme *sc, enum scheme_opcodes op);
-+static pointer opexe_6(scheme *sc, enum scheme_opcodes op);
-+static void Eval_Cycle(scheme *sc, enum scheme_opcodes op);
-+static void assign_syntax(scheme *sc, char *name);
-+static int syntaxnum(pointer p);
-+static void assign_proc(scheme *sc, enum scheme_opcodes, char *name);
-+
-+#define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
-+#define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
-+
-+static num num_add(num a, num b) {
-+ num ret;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(ret.is_fixnum) {
-+     ret.value.ivalue= a.value.ivalue+b.value.ivalue;
-+ } else {
-+     ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static num num_mul(num a, num b) {
-+ num ret;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(ret.is_fixnum) {
-+     ret.value.ivalue= a.value.ivalue*b.value.ivalue;
-+ } else {
-+     ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static num num_div(num a, num b) {
-+ num ret;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum && a.value.ivalue%b.value.ivalue==0;
-+ if(ret.is_fixnum) {
-+     ret.value.ivalue= a.value.ivalue/b.value.ivalue;
-+ } else {
-+     ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static num num_intdiv(num a, num b) {
-+ num ret;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(ret.is_fixnum) {
-+     ret.value.ivalue= a.value.ivalue/b.value.ivalue;
-+ } else {
-+     ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static num num_sub(num a, num b) {
-+ num ret;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(ret.is_fixnum) {
-+     ret.value.ivalue= a.value.ivalue-b.value.ivalue;
-+ } else {
-+     ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static num num_rem(num a, num b) {
-+ num ret;
-+ long e1, e2, res;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ e1=num_ivalue(a);
-+ e2=num_ivalue(b);
-+ res=e1%e2;
-+ /* remainder should have same sign as second operand */
-+ if (res > 0) {
-+     if (e1 < 0) {
-+        res -= labs(e2);
-+     }
-+ } else if (res < 0) {
-+     if (e1 > 0) {
-+         res += labs(e2);
-+     }
-+ }
-+ ret.value.ivalue=res;
-+ return ret;
-+}
-+
-+static num num_mod(num a, num b) {
-+ num ret;
-+ long e1, e2, res;
-+ ret.is_fixnum=a.is_fixnum && b.is_fixnum;
-+ e1=num_ivalue(a);
-+ e2=num_ivalue(b);
-+ res=e1%e2;
-+ /* modulo should have same sign as second operand */
-+ if (res * e2 < 0) {
-+    res += e2;
-+ }
-+ ret.value.ivalue=res;
-+ return ret;
-+}
-+
-+static int num_eq(num a, num b) {
-+ int ret;
-+ int is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(is_fixnum) {
-+     ret= a.value.ivalue==b.value.ivalue;
-+ } else {
-+     ret=num_rvalue(a)==num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+
-+static int num_gt(num a, num b) {
-+ int ret;
-+ int is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(is_fixnum) {
-+     ret= a.value.ivalue>b.value.ivalue;
-+ } else {
-+     ret=num_rvalue(a)>num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static int num_ge(num a, num b) {
-+ return !num_lt(a,b);
-+}
-+
-+static int num_lt(num a, num b) {
-+ int ret;
-+ int is_fixnum=a.is_fixnum && b.is_fixnum;
-+ if(is_fixnum) {
-+     ret= a.value.ivalue<b.value.ivalue;
-+ } else {
-+     ret=num_rvalue(a)<num_rvalue(b);
-+ }
-+ return ret;
-+}
-+
-+static int num_le(num a, num b) {
-+ return !num_gt(a,b);
-+}
-+
-+#if USE_MATH
-+/* Round to nearest. Round to even if midway */
-+static double round_per_R5RS(double x) {
-+ double fl=floor(x);
-+ double ce=ceil(x);
-+ double dfl=x-fl;
-+ double dce=ce-x;
-+ if(dfl>dce) {
-+     return ce;
-+ } else if(dfl<dce) {
-+     return fl;
-+ } else {
-+     if(fmod(fl,2.0)==0.0) {       /* I imagine this holds */
-+          return fl;
-+     } else {
-+          return ce;
-+     }
-+ }
-+}
-+#endif
-+
-+static int is_zero_double(double x) {
-+ return x<DBL_MIN && x>-DBL_MIN;
-+}
-+
-+static long binary_decode(const char *s) {
-+ long x=0;
-+
-+ while(*s!=0 && (*s=='1' || *s=='0')) {
-+     x<<=1;
-+     x+=*s-'0';
-+     s++;
-+ }
-+
-+ return x;
-+}
-+
-+/* allocate new cell segment */
-+static int alloc_cellseg(scheme *sc, int n) {
-+     pointer newp;
-+     pointer last;
-+     pointer p;
-+     char *cp;
-+     long i;
-+     int k;
-+     int adj=ADJ;
-+
-+     if(adj<sizeof(struct cell)) {
-+       adj=sizeof(struct cell);
-+     }
-+
-+     for (k = 0; k < n; k++) {
-+         if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
-+              return k;
-+         cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
-+         if (cp == 0)
-+              return k;
-+         i = ++sc->last_cell_seg ;
-+         sc->alloc_seg[i] = cp;
-+         /* adjust in TYPE_BITS-bit boundary */
-+         if(((unsigned long)cp)%adj!=0) {
-+           cp=(char*)(adj*((unsigned long)cp/adj+1));
-+         }
-+         /* insert new segment in address order */
-+         newp=(pointer)cp;
-+         sc->cell_seg[i] = newp;
-+         while (i > 0 && sc->cell_seg[i - 1] > sc->cell_seg[i]) {
-+             p = sc->cell_seg[i];
-+             sc->cell_seg[i] = sc->cell_seg[i - 1];
-+             sc->cell_seg[--i] = p;
-+         }
-+         sc->fcells += CELL_SEGSIZE;
-+         last = newp + CELL_SEGSIZE - 1;
-+         for (p = newp; 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 = newp;
-+         } else {
-+               p = sc->free_cell;
-+               while (cdr(p) != sc->NIL && newp > cdr(p))
-+                    p = cdr(p);
-+               cdr(last) = cdr(p);
-+               cdr(p) = newp;
-+         }
-+     }
-+     return n;
-+}
-+
-+static INLINE pointer get_cell_x(scheme *sc, pointer a, pointer b) {
-+  if (sc->free_cell != sc->NIL) {
-+    pointer x = sc->free_cell;
-+    sc->free_cell = cdr(x);
-+    --sc->fcells;
-+    return (x);
-+  }
-+  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;
-+  }
-+
-+  if (sc->free_cell == sc->NIL) {
-+    const int min_to_be_recovered = sc->last_cell_seg*8;
-+    gc(sc,a, b);
-+    if (sc->fcells < min_to_be_recovered
-+        || sc->free_cell == sc->NIL) {
-+      /* if only a few recovered, get more to avoid fruitless gc's */
-+      if (!alloc_cellseg(sc,1) && 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;
-+}
-+
-+/* 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 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;
-+  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,len/2+len%2+1);
-+  if(sc->no_memory) { return sc->sink; }
-+  /* Record it as a vector so that gc understands it. */
-+  typeflag(cells) = (T_VECTOR | T_ATOM);
-+  ivalue_unchecked(cells)=len;
-+  set_num_integer(cells);
-+  fill_vector(cells,init);
-+  push_recent_alloc(sc, cells, sc->NIL);
-+  return cells;
-+}
-+
-+static INLINE void ok_to_freely_gc(scheme *sc)
-+{
-+  car(sc->sink) = sc->NIL;
-+}
-+
-+
-+#if defined TSGRIND
-+static void check_cell_alloced(pointer p, int expect_alloced)
-+{
-+  /* Can't use putstr(sc,str) because callers have no access to
-+     sc.  */
-+  if(typeflag(p) & !expect_alloced)
-+    {
-+      fprintf(stderr,"Cell is already allocated!\n");
-+    }
-+  if(!(typeflag(p)) & expect_alloced)
-+    {
-+      fprintf(stderr,"Cell is not allocated!\n");
-+    }
-+
-+}
-+static void check_range_alloced(pointer p, int n, int expect_alloced)
-+{
-+  int i;
-+  for(i = 0;i<n;i++)
-+    { (void)check_cell_alloced(p+i,expect_alloced); }
-+}
-+
-+#endif
-+
-+/* 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)
-+{
-+  return mk_vector(sc, 461); /* probably should be bigger */
-+}
-+
-+/* returns the new symbol */
-+static pointer oblist_add_by_name(scheme *sc, const char *name)
-+{
-+  pointer x;
-+  int location;
-+
-+  x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
-+  typeflag(x) = T_SYMBOL;
-+  setimmutable(car(x));
-+
-+  location = hash_fn(name, ivalue_unchecked(sc->oblist));
-+  set_vector_elem(sc->oblist, location,
-+                  immutable_cons(sc, x, vector_elem(sc->oblist, location)));
-+  return x;
-+}
-+
-+static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
-+{
-+  int location;
-+  pointer x;
-+  char *s;
-+
-+  location = hash_fn(name, ivalue_unchecked(sc->oblist));
-+  for (x = vector_elem(sc->oblist, location); x != sc->NIL; x = cdr(x)) {
-+    s = symname(car(x));
-+    /* case-insensitive, per R5RS section 2. */
-+    if(stricmp(name, s) == 0) {
-+      return car(x);
-+    }
-+  }
-+  return sc->NIL;
-+}
-+
-+static pointer oblist_all_symbols(scheme *sc)
-+{
-+  int i;
-+  pointer x;
-+  pointer ob_list = sc->NIL;
-+
-+  for (i = 0; i < ivalue_unchecked(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;
-+}
-+
-+static INLINE pointer oblist_find_by_name(scheme *sc, const char *name)
-+{
-+     pointer x;
-+     char    *s;
-+
-+     for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
-+        s = symname(car(x));
-+        /* case-insensitive, per R5RS section 2. */
-+        if(stricmp(name, s) == 0) {
-+          return car(x);
-+        }
-+     }
-+     return sc->NIL;
-+}
-+
-+/* returns the new symbol */
-+static pointer oblist_add_by_name(scheme *sc, const char *name)
-+{
-+  pointer x;
-+
-+  x = immutable_cons(sc, mk_string(sc, name), sc->NIL);
-+  typeflag(x) = T_SYMBOL;
-+  setimmutable(car(x));
-+  sc->oblist = immutable_cons(sc, x, sc->oblist);
-+  return x;
-+}
-+static pointer oblist_all_symbols(scheme *sc)
-+{
-+  return sc->oblist;
-+}
-+
-+#endif
-+
-+static pointer mk_port(scheme *sc, port *p) {
-+  pointer x = get_cell(sc, sc->NIL, sc->NIL);
-+
-+  typeflag(x) = T_PORT|T_ATOM;
-+  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);
-+}
-+
-+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);
-+}
-+
-+/* get number atom (integer) */
-+INTERFACE pointer mk_integer(scheme *sc, long num) {
-+  pointer x = get_cell(sc,sc->NIL, sc->NIL);
-+
-+  typeflag(x) = (T_NUMBER | T_ATOM);
-+  ivalue_unchecked(x)= num;
-+  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) {
-+          snprintf(q, len_str+1, "%s", str);
-+     } 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);
-+     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);
-+     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) {
-+     int i;
-+     int num=ivalue(vec)/2+ivalue(vec)%2;
-+     for(i=0; i<num; i++) {
-+          typeflag(vec+1+i) = T_PAIR;
-+          setimmutable(vec+1+i);
-+          car(vec+1+i)=obj;
-+          cdr(vec+1+i)=obj;
-+     }
-+}
-+
-+INTERFACE static pointer vector_elem(pointer vec, int ielem) {
-+     int n=ielem/2;
-+     if(ielem%2==0) {
-+          return car(vec+1+n);
-+     } else {
-+          return cdr(vec+1+n);
-+     }
-+}
-+
-+INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
-+     int n=ielem/2;
-+     if(ielem%2==0) {
-+          return car(vec+1+n)=a;
-+     } else {
-+          return cdr(vec+1+n)=a;
-+     }
-+}
-+
-+/* get new symbol */
-+INTERFACE pointer mk_symbol(scheme *sc, const char *name) {
-+     pointer x;
-+
-+     /* first check oblist */
-+     x = oblist_find_by_name(sc, name);
-+     if (x != sc->NIL) {
-+          return (x);
-+     } else {
-+          x = oblist_add_by_name(sc, name);
-+          return (x);
-+     }
-+}
-+
-+INTERFACE pointer gensym(scheme *sc) {
-+     pointer x;
-+     char name[40];
-+
-+     for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
-+          snprintf(name,40,"gensym-%ld",sc->gensym_cnt);
-+
-+          /* first check oblist */
-+          x = oblist_find_by_name(sc, name);
-+
-+          if (x != sc->NIL) {
-+               continue;
-+          } else {
-+               x = oblist_add_by_name(sc, name);
-+               return (x);
-+          }
-+     }
-+
-+     return sc->NIL;
-+}
-+
-+/* 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
-+     if((p=strstr(q,"::"))!=0) {
-+          *p=0;
-+          return cons(sc, sc->COLON_HOOK,
-+                          cons(sc,
-+                              cons(sc,
-+                                   sc->QUOTE,
-+                                   cons(sc, mk_atom(sc,p+2), sc->NIL)),
-+                              cons(sc, mk_symbol(sc,strlwr(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 ========== */
-+
-+/*--
-+ *  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:  setmark(p);
-+     if(is_vector(p)) {
-+          int i;
-+          int num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
-+          for(i=0; i<num; i++) {
-+               /* Vector cells will be treated like ordinary cells */
-+               mark(p+1+i);
-+          }
-+     }
-+     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;
-+  int i;
-+
-+  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);
-+  dump_stack_mark(sc);
-+  mark(sc->value);
-+  mark(sc->inport);
-+  mark(sc->save_inport);
-+  mark(sc->outport);
-+  mark(sc->loadport);
-+
-+  /* 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 (i = sc->last_cell_seg; i >= 0; i--) {
-+    p = sc->cell_seg[i] + CELL_SEGSIZE;
-+    while (--p >= sc->cell_seg[i]) {
-+      if (is_mark(p)) {
-+    clrmark(p);
-+      } else {
-+    /* reclaim cell */
-+        if (typeflag(p) != 0) {
-+          finalize_cell(sc, p);
-+          typeflag(p) = 0;
-+          car(p) = sc->NIL;
-+        }
-+        ++sc->fcells;
-+        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);
-+  }
-+}
-+
-+static void finalize_cell(scheme *sc, pointer a) {
-+  if(is_string(a)) {
-+    sc->free(strvalue(a));
-+  } else if(is_port(a)) {
-+    if(a->_object._port->kind&port_file
-+       && a->_object._port->rep.stdio.closeit) {
-+      port_close(sc,a,port_input|port_output);
-+    }
-+    sc->free(a->_object._port);
-+  }
-+}
-+
-+/* ========== Routines for Reading ========== */
-+
-+static int file_push(scheme *sc, const char *fname) {
-+  FILE *fin = NULL;
-+
-+  if (sc->file_i == MAXFIL-1)
-+     return 0;
-+  fin=fopen(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;
-+
-+#if SHOW_ERROR_LINE
-+    sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
-+    if(fname)
-+      sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
-+#endif
-+  }
-+  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);
-+   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;
-+
-+#if SHOW_ERROR_LINE
-+  if(fn)
-+    pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);
-+
-+  pt->rep.stdio.curr_line = 0;
-+#endif
-+  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;
-+    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;
-+  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;
-+  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) {
-+    if(pt->kind&port_file) {
-+
-+#if SHOW_ERROR_LINE
-+      /* Cleanup is here so (close-*-port) functions could work too */
-+      pt->rep.stdio.curr_line = 0;
-+
-+      if(pt->rep.stdio.filename)
-+        sc->free(pt->rep.stdio.filename);
-+#endif
-+
-+      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 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';
-+    strcpy(str,start);
-+    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 < sizeof(sc->strbuff)) &&
-+         !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 || p-sc->strbuff > sizeof(sc->strbuff)-1) {
-+      return sc->F;
-+    }
-+    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 */
-+#if SHOW_ERROR_LINE
-+     if (sc->load_stack[sc->file_i].kind & port_file)
-+       sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
-+#endif
-+
-+     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 SHOW_ERROR_LINE
-+           if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
-+             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-+#endif
-+
-+       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 SHOW_ERROR_LINE
-+           if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
-+             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-+#endif
-+
-+           if(c == EOF)
-+             { return (TOK_EOF); }
-+           else
-+             { return (token(sc));}
-+          } else {
-+               backchar(sc,c);
-+               if(is_one_of(" tfodxb\\",c)) {
-+                    return TOK_SHARP_CONST;
-+               } else {
-+                    return (TOK_SHARP);
-+               }
-+          }
-+     default:
-+          backchar(sc,c);
-+          return (TOK_ATOM);
-+     }
-+}
-+
-+/* ========== Routines for Printing ========== */
-+#define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)
-+
-+static void printslashstring(scheme *sc, char *p, int len) {
-+  int i;
-+  unsigned char *s=(unsigned char*)p;
-+  putcharacter(sc,'"');
-+  for ( i=0; i<len; i++) {
-+    if(*s==0xff || *s=='"' || *s<' ' || *s=='\\') {
-+      putcharacter(sc,'\\');
-+      switch(*s) {
-+      case '"':
-+        putcharacter(sc,'"');
-+        break;
-+      case '\n':
-+        putcharacter(sc,'n');
-+        break;
-+      case '\t':
-+        putcharacter(sc,'t');
-+        break;
-+      case '\r':
-+        putcharacter(sc,'r');
-+        break;
-+      case '\\':
-+        putcharacter(sc,'\\');
-+        break;
-+      default: {
-+          int d=*s/16;
-+          putcharacter(sc,'x');
-+          if(d<10) {
-+            putcharacter(sc,d+'0');
-+          } else {
-+            putcharacter(sc,d-10+'A');
-+          }
-+          d=*s%16;
-+          if(d<10) {
-+            putcharacter(sc,d+'0');
-+          } else {
-+            putcharacter(sc,d-10+'A');
-+          }
-+        }
-+      }
-+    } else {
-+      putcharacter(sc,*s);
-+    }
-+    s++;
-+  }
-+  putcharacter(sc,'"');
-+}
-+
-+
-+/* print atoms */
-+static void printatom(scheme *sc, pointer l, int f) {
-+  char *p;
-+  int len;
-+  atom2str(sc,l,f,&p,&len);
-+  putchars(sc,p,len);
-+}
-+
-+
-+/* Uses internal buffer unless string pointer is already available */
-+static void atom2str(scheme *sc, pointer l, int f, char **pp, int *plen) {
-+     char *p;
-+
-+     if (l == sc->NIL) {
-+          p = "()";
-+     } else if (l == sc->T) {
-+          p = "#t";
-+     } else if (l == sc->F) {
-+          p = "#f";
-+     } else if (l == sc->EOF_OBJ) {
-+          p = "#<EOF>";
-+     } else if (is_port(l)) {
-+          p = sc->strbuff;
-+          snprintf(p, STRBUFFSIZE, "#<PORT>");
-+     } else if (is_number(l)) {
-+          p = sc->strbuff;
-+          if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ {
-+              if(num_is_integer(l)) {
-+                   snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
-+              } else {
-+                   snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
-+                   /* r5rs says there must be a '.' (unless 'e'?) */
-+                   f = strcspn(p, ".e");
-+                   if (p[f] == 0) {
-+                        p[f] = '.'; /* not found, so add '.0' at the end */
-+                        p[f+1] = '0';
-+                        p[f+2] = 0;
-+                   }
-+              }
-+          } else {
-+              long v = ivalue(l);
-+              if (f == 16) {
-+                  if (v >= 0)
-+                    snprintf(p, STRBUFFSIZE, "%lx", v);
-+                  else
-+                    snprintf(p, STRBUFFSIZE, "-%lx", -v);
-+              } else if (f == 8) {
-+                  if (v >= 0)
-+                    snprintf(p, STRBUFFSIZE, "%lo", v);
-+                  else
-+                    snprintf(p, STRBUFFSIZE, "-%lo", -v);
-+              } else if (f == 2) {
-+                  unsigned long b = (v < 0) ? -v : v;
-+                  p = &p[STRBUFFSIZE-1];
-+                  *p = 0;
-+                  do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
-+                  if (v < 0) *--p = '-';
-+              }
-+          }
-+     } else if (is_string(l)) {
-+          if (!f) {
-+               p = strvalue(l);
-+          } 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 ' ':
-+                    snprintf(p,STRBUFFSIZE,"#\\space"); break;
-+               case '\n':
-+                    snprintf(p,STRBUFFSIZE,"#\\newline"); break;
-+               case '\r':
-+                    snprintf(p,STRBUFFSIZE,"#\\return"); break;
-+               case '\t':
-+                    snprintf(p,STRBUFFSIZE,"#\\tab"); break;
-+               default:
-+#if USE_ASCII_NAMES
-+                    if(c==127) {
-+                         snprintf(p,STRBUFFSIZE, "#\\del");
-+                         break;
-+                    } else if(c<32) {
-+                         snprintf(p, STRBUFFSIZE, "#\\%s", charnames[c]);
-+                         break;
-+                    }
-+#else
-+                    if(c<32) {
-+                      snprintf(p,STRBUFFSIZE,"#\\x%x",c); break;
-+                      break;
-+                    }
-+#endif
-+                    snprintf(p,STRBUFFSIZE,"#\\%c",c); break;
-+                    break;
-+               }
-+          }
-+     } else if (is_symbol(l)) {
-+          p = symname(l);
-+     } else if (is_proc(l)) {
-+          p = sc->strbuff;
-+          snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
-+     } else if (is_macro(l)) {
-+          p = "#<MACRO>";
-+     } else if (is_closure(l)) {
-+          p = "#<CLOSURE>";
-+     } else if (is_promise(l)) {
-+          p = "#<PROMISE>";
-+     } else if (is_foreign(l)) {
-+          p = sc->strbuff;
-+          snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
-+     } else if (is_continuation(l)) {
-+          p = "#<CONTINUATION>";
-+     } else {
-+          p = "#<ERROR>";
-+     }
-+     *pp=p;
-+     *plen=strlen(p);
-+}
-+/* ========== Routines for Evaluation Cycle ========== */
-+
-+/* make closure. c is code. e is environment */
-+static pointer mk_closure(scheme *sc, pointer c, pointer e) {
-+     pointer x = get_cell(sc, c, e);
-+
-+     typeflag(x) = T_CLOSURE;
-+     car(x) = c;
-+     cdr(x) = e;
-+     return (x);
-+}
-+
-+/* make continuation. */
-+static pointer mk_continuation(scheme *sc, pointer d) {
-+     pointer x = get_cell(sc, sc->NIL, d);
-+
-+     typeflag(x) = T_CONTINUATION;
-+     cont_dump(x) = d;
-+     return (x);
-+}
-+
-+static pointer list_star(scheme *sc, pointer d) {
-+  pointer p, q;
-+  if(cdr(d)==sc->NIL) {
-+    return car(d);
-+  }
-+  p=cons(sc,car(d),cdr(d));
-+  q=p;
-+  while(cdr(cdr(p))!=sc->NIL) {
-+    d=cons(sc,car(p),cdr(p));
-+    if(cdr(cdr(p))!=sc->NIL) {
-+      p=cdr(d);
-+    }
-+  }
-+  cdr(p)=car(cdr(p));
-+  return q;
-+}
-+
-+/* reverse list -- produce new list */
-+static pointer reverse(scheme *sc, pointer a) {
-+/* a must be checked by gc */
-+     pointer p = sc->NIL;
-+
-+     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
-+
-+#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 300 variables in it. */
-+  if (old_env == sc->NIL) {
-+    new_frame = mk_vector(sc, 461);
-+  } else {
-+    new_frame = sc->NIL;
-+  }
-+
-+  sc->envir = immutable_cons(sc, new_frame, old_env);
-+  setenvironment(sc->envir);
-+}
-+
-+static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-+                                        pointer variable, pointer value)
-+{
-+  pointer slot = immutable_cons(sc, variable, value);
-+
-+  if (is_vector(car(env))) {
-+    int location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
-+
-+    set_vector_elem(car(env), location,
-+                    immutable_cons(sc, slot, vector_elem(car(env), location)));
-+  } else {
-+    car(env) = immutable_cons(sc, slot, car(env));
-+  }
-+}
-+
-+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
-+{
-+  pointer x,y;
-+  int location;
-+
-+  for (x = env; x != sc->NIL; x = cdr(x)) {
-+    if (is_vector(car(x))) {
-+      location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
-+      y = vector_elem(car(x), location);
-+    } else {
-+      y = car(x);
-+    }
-+    for ( ; y != sc->NIL; y = cdr(y)) {
-+              if (caar(y) == hdl) {
-+                   break;
-+              }
-+         }
-+         if (y != sc->NIL) {
-+              break;
-+         }
-+         if(!all) {
-+           return sc->NIL;
-+         }
-+    }
-+    if (x != sc->NIL) {
-+          return car(y);
-+    }
-+    return sc->NIL;
-+}
-+
-+#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);
-+}
-+
-+static INLINE void new_slot_spec_in_env(scheme *sc, pointer env,
-+                                        pointer variable, pointer value)
-+{
-+  car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
-+}
-+
-+static pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, int all)
-+{
-+    pointer x,y;
-+    for (x = env; x != sc->NIL; x = cdr(x)) {
-+         for (y = car(x); y != sc->NIL; y = cdr(y)) {
-+              if (caar(y) == hdl) {
-+                   break;
-+              }
-+         }
-+         if (y != sc->NIL) {
-+              break;
-+         }
-+         if(!all) {
-+           return sc->NIL;
-+         }
-+    }
-+    if (x != sc->NIL) {
-+          return car(y);
-+    }
-+    return sc->NIL;
-+}
-+
-+#endif /* USE_ALIST_ENV else */
-+
-+static INLINE void new_slot_in_env(scheme *sc, pointer variable, pointer value)
-+{
-+  new_slot_spec_in_env(sc, sc->envir, variable, value);
-+}
-+
-+static INLINE void set_slot_in_env(scheme *sc, pointer slot, pointer value)
-+{
-+  cdr(slot) = value;
-+}
-+
-+static INLINE pointer slot_value_in_env(pointer slot)
-+{
-+  return cdr(slot);
-+}
-+
-+/* ========== Evaluation Cycle ========== */
-+
-+
-+static pointer _Error_1(scheme *sc, const char *s, pointer a) {
-+     const char *str = s;
-+#if USE_ERROR_HOOK
-+     pointer x;
-+     pointer hdl=sc->ERROR_HOOK;
-+#endif
-+
-+#if SHOW_ERROR_LINE
-+     char sbuf[STRBUFFSIZE];
-+
-+     /* make sure error is not in REPL */
-+     if (sc->load_stack[sc->file_i].kind & port_file &&
-+         sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
-+       int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
-+       const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;
-+
-+       /* should never happen */
-+       if(!fname) fname = "<unknown>";
-+
-+       /* we started from 0 */
-+       ln++;
-+       snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
-+
-+       str = (const char*)sbuf;
-+     }
-+#endif
-+
-+#if USE_ERROR_HOOK
-+     x=find_slot_in_env(sc,sc->envir,hdl,1);
-+    if (x != sc->NIL) {
-+         if(a!=0) {
-+               sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
-+         } else {
-+               sc->code = sc->NIL;
-+         }
-+         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);
-+         sc->op = (int)OP_EVAL;
-+         return sc->T;
-+    }
-+#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));
-+    sc->op = (int)OP_ERR0;
-+    return sc->T;
-+}
-+#define Error_1(sc,s, a) return _Error_1(sc,s,a)
-+#define Error_0(sc,s)    return _Error_1(sc,s,0)
-+
-+/* Too small to turn into function */
-+# define  BEGIN     do {
-+# define  END  } while (0)
-+#define s_goto(sc,a) BEGIN                                  \
-+    sc->op = (int)(a);                                      \
-+    return sc->T; END
-+
-+#define s_return(sc,a) return _s_return(sc,a)
-+
-+#ifndef USE_SCHEME_STACK
-+
-+/* this structure holds all the interpreter's registers */
-+struct dump_stack_frame {
-+  enum scheme_opcodes op;
-+  pointer args;
-+  pointer envir;
-+  pointer code;
-+};
-+
-+#define STACK_GROWTH 3
-+
-+static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code)
-+{
-+  int nframes = (int)sc->dump;
-+  struct dump_stack_frame *next_frame;
-+
-+  /* enough room for the next frame? */
-+  if (nframes >= sc->dump_size) {
-+    sc->dump_size += STACK_GROWTH;
-+    /* alas there is no sc->realloc */
-+    sc->dump_base = realloc(sc->dump_base,
-+                            sizeof(struct dump_stack_frame) * sc->dump_size);
-+  }
-+  next_frame = (struct dump_stack_frame *)sc->dump_base + nframes;
-+  next_frame->op = op;
-+  next_frame->args = args;
-+  next_frame->envir = sc->envir;
-+  next_frame->code = code;
-+  sc->dump = (pointer)(nframes+1);
-+}
-+
-+static pointer _s_return(scheme *sc, pointer a)
-+{
-+  int nframes = (int)sc->dump;
-+  struct dump_stack_frame *frame;
-+
-+  sc->value = (a);
-+  if (nframes <= 0) {
-+    return sc->NIL;
-+  }
-+  nframes--;
-+  frame = (struct dump_stack_frame *)sc->dump_base + nframes;
-+  sc->op = frame->op;
-+  sc->args = frame->args;
-+  sc->envir = frame->envir;
-+  sc->code = frame->code;
-+  sc->dump = (pointer)nframes;
-+  return sc->T;
-+}
-+
-+static INLINE void dump_stack_reset(scheme *sc)
-+{
-+  /* in this implementation, sc->dump is the number of frames on the stack */
-+  sc->dump = (pointer)0;
-+}
-+
-+static INLINE void dump_stack_initialize(scheme *sc)
-+{
-+  sc->dump_size = 0;
-+  sc->dump_base = NULL;
-+  dump_stack_reset(sc);
-+}
-+
-+static void dump_stack_free(scheme *sc)
-+{
-+  free(sc->dump_base);
-+  sc->dump_base = NULL;
-+  sc->dump = (pointer)0;
-+  sc->dump_size = 0;
-+}
-+
-+static INLINE void dump_stack_mark(scheme *sc)
-+{
-+  int nframes = (int)sc->dump;
-+  int i;
-+  for(i=0; i<nframes; i++) {
-+    struct dump_stack_frame *frame;
-+    frame = (struct dump_stack_frame *)sc->dump_base + i;
-+    mark(frame->args);
-+    mark(frame->envir);
-+    mark(frame->code);
-+  }
-+}
-+
-+#else
-+
-+static INLINE void dump_stack_reset(scheme *sc)
-+{
-+  sc->dump = sc->NIL;
-+}
-+
-+static INLINE void dump_stack_initialize(scheme *sc)
-+{
-+  dump_stack_reset(sc);
-+}
-+
-+static void dump_stack_free(scheme *sc)
-+{
-+  sc->dump = sc->NIL;
-+}
-+
-+static pointer _s_return(scheme *sc, pointer a) {
-+    sc->value = (a);
-+    if(sc->dump==sc->NIL) return sc->NIL;
-+    sc->op = ivalue(car(sc->dump));
-+    sc->args = cadr(sc->dump);
-+    sc->envir = caddr(sc->dump);
-+    sc->code = cadddr(sc->dump);
-+    sc->dump = cddddr(sc->dump);
-+    return sc->T;
-+}
-+
-+static void s_save(scheme *sc, enum scheme_opcodes op, pointer args, pointer code) {
-+    sc->dump = cons(sc, sc->envir, cons(sc, (code), sc->dump));
-+    sc->dump = cons(sc, (args), sc->dump);
-+    sc->dump = cons(sc, mk_integer(sc, (long)(op)), sc->dump);
-+}
-+
-+static INLINE void dump_stack_mark(scheme *sc)
-+{
-+  mark(sc->dump);
-+}
-+#endif
-+
-+#define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)
-+
-+static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
-+     pointer x, y;
-+
-+     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,strvalue(car(sc->args)))) {
-+               Error_1(sc,"unable to open", car(sc->args));
-+          }
-+      else
-+        {
-+          sc->args = mk_integer(sc,sc->file_i);
-+          s_goto(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;
-+           s_goto(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_goto(sc,OP_READ_INTERNAL);
-+
-+     case OP_T1LVL: /* top level */
-+          sc->code = sc->value;
-+          sc->inport=sc->save_inport;
-+          s_goto(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_goto(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_goto(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_goto(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(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_goto(sc,OP_EVAL);
-+               }
-+          } else {
-+               s_return(sc,sc->code);
-+          }
-+
-+     case OP_E0ARGS:     /* eval arguments */
-+          if (is_macro(sc->value)) {    /* macro expansion */
-+               s_save(sc,OP_DOMACRO, sc->NIL, sc->NIL);
-+               sc->args = cons(sc,sc->code, sc->NIL);
-+               sc->code = sc->value;
-+               s_goto(sc,OP_APPLY);
-+          } else {
-+               sc->code = cdr(sc->code);
-+               s_goto(sc,OP_E1ARGS);
-+          }
-+
-+     case OP_E1ARGS:     /* eval arguments */
-+          sc->args = cons(sc, sc->value, sc->args);
-+          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_goto(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_goto(sc,OP_APPLY);
-+          }
-+
-+#if USE_TRACING
-+     case OP_TRACING: {
-+       int tr=sc->tracing;
-+       sc->tracing=ivalue(car(sc->args));
-+       s_return(sc,mk_integer(sc,tr));
-+     }
-+#endif
-+
-+     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_goto(sc,OP_P0LIST);
-+       }
-+       /* fall through */
-+     case OP_REAL_APPLY:
-+#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_0(sc,"not enough arguments");
-+                    } else {
-+                         new_slot_in_env(sc, car(x), car(y));
-+                    }
-+               }
-+               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_goto(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_0(sc,"illegal function");
-+          }
-+
-+     case OP_DOMACRO:    /* do macro */
-+          sc->code = sc->value;
-+          s_goto(sc,OP_EVAL);
-+
-+#if 1
-+     case OP_LAMBDA:     /* lambda */
-+          /* If the hook is defined, apply it to sc->code, otherwise
-+             set sc->value fall thru */
-+          {
-+               pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
-+               if(f==sc->NIL) {
-+                    sc->value = sc->code;
-+                    /* Fallthru */
-+               } else {
-+                    s_save(sc,OP_LAMBDA1,sc->args,sc->code);
-+                    sc->args=cons(sc,sc->code,sc->NIL);
-+                    sc->code=slot_value_in_env(f);
-+                    s_goto(sc,OP_APPLY);
-+               }
-+          }
-+
-+     case OP_LAMBDA1:
-+          s_return(sc,mk_closure(sc, sc->value, sc->envir));
-+
-+#else
-+     case OP_LAMBDA:     /* lambda */
-+          s_return(sc,mk_closure(sc, sc->code, sc->envir));
-+
-+#endif
-+
-+     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);
-+       }
-+       s_return(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);
-+               sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
-+          } 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_goto(sc,OP_EVAL);
-+
-+     case OP_DEF1:  /* define */
-+          x=find_slot_in_env(sc,sc->envir,sc->code,0);
-+          if (x != sc->NIL) {
-+               set_slot_in_env(sc, x, sc->value);
-+          } else {
-+               new_slot_in_env(sc, sc->code, sc->value);
-+          }
-+          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_goto(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 */
-+          if (!is_pair(sc->code)) {
-+               s_return(sc,sc->code);
-+          }
-+          if (cdr(sc->code) != sc->NIL) {
-+               s_save(sc,OP_BEGIN, sc->NIL, cdr(sc->code));
-+          }
-+          sc->code = car(sc->code);
-+          s_goto(sc,OP_EVAL);
-+
-+     case OP_IF0:        /* if */
-+          s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
-+          sc->code = car(sc->code);
-+          s_goto(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_goto(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_goto(sc,OP_LET1);
-+
-+     case OP_LET1:       /* let (calculate parameters) */
-+          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))) {
-+                    Error_1(sc, "Bad syntax of binding spec in let :",
-+                            car(sc->code));
-+               }
-+               s_save(sc,OP_LET1, sc->args, cdr(sc->code));
-+               sc->code = cadar(sc->code);
-+               sc->args = sc->NIL;
-+               s_goto(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_goto(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));
-+                    sc->args = cons(sc, caar(x), sc->args);
-+               }
-+               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);
-+               sc->code = cddr(sc->code);
-+               sc->args = sc->NIL;
-+          } else {
-+               sc->code = cdr(sc->code);
-+               sc->args = sc->NIL;
-+          }
-+          s_goto(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_goto(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_goto(sc,OP_EVAL);
-+
-+     case OP_LET1AST:    /* let* (make new frame) */
-+          new_frame_in_env(sc, sc->envir);
-+          s_goto(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_goto(sc,OP_EVAL);
-+          } else {  /* end */
-+               sc->code = sc->args;
-+               sc->args = sc->NIL;
-+               s_goto(sc,OP_BEGIN);
-+          }
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+     }
-+     return sc->T;
-+}
-+
-+static pointer opexe_1(scheme *sc, enum scheme_opcodes op) {
-+     pointer x, y;
-+
-+     switch (op) {
-+     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_goto(sc,OP_LET1REC);
-+
-+     case OP_LET1REC:    /* letrec (calculate parameters) */
-+          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))) {
-+                    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_goto(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_goto(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_goto(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_goto(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(car(sc->code)==sc->FEED_TO) {
-+                    if(!is_pair(cdr(sc->code))) {
-+                         Error_0(sc,"syntax error in cond");
-+                    }
-+                    x=cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL));
-+                    sc->code=cons(sc,cadr(sc->code),cons(sc,x,sc->NIL));
-+                    s_goto(sc,OP_EVAL);
-+               }
-+               s_goto(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_goto(sc,OP_EVAL);
-+               }
-+          }
-+
-+     case OP_DELAY:      /* delay */
-+          x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
-+          typeflag(x)=T_PROMISE;
-+          s_return(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));
-+          sc->code = car(sc->code);
-+          s_goto(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));
-+               sc->code = car(sc->code);
-+               s_goto(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));
-+          sc->code = car(sc->code);
-+          s_goto(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));
-+               sc->code = car(sc->code);
-+               s_goto(sc,OP_EVAL);
-+          }
-+
-+     case OP_C0STREAM:   /* cons-stream */
-+          s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
-+          sc->code = car(sc->code);
-+          s_goto(sc,OP_EVAL);
-+
-+     case OP_C1STREAM:   /* cons-stream */
-+          sc->args = sc->value;  /* save sc->value to register sc->args for gc */
-+          x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
-+          typeflag(x)=T_PROMISE;
-+          s_return(sc,cons(sc, sc->args, x));
-+
-+     case OP_MACRO0:     /* macro */
-+          if (is_pair(car(sc->code))) {
-+               x = caar(sc->code);
-+               sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
-+          } 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_goto(sc,OP_EVAL);
-+
-+     case OP_MACRO1:     /* macro */
-+          typeflag(sc->value) = T_MACRO;
-+          x = find_slot_in_env(sc, sc->envir, sc->code, 0);
-+          if (x != sc->NIL) {
-+               set_slot_in_env(sc, x, sc->value);
-+          } else {
-+               new_slot_in_env(sc, sc->code, sc->value);
-+          }
-+          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_goto(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_goto(sc,OP_BEGIN);
-+               } else {/* else */
-+                    s_save(sc,OP_CASE2, sc->NIL, cdar(x));
-+                    sc->code = caar(x);
-+                    s_goto(sc,OP_EVAL);
-+               }
-+          } else {
-+               s_return(sc,sc->NIL);
-+          }
-+
-+     case OP_CASE2:      /* case */
-+          if (is_true(sc->value)) {
-+               s_goto(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_goto(sc,OP_APPLY);
-+
-+     case OP_PEVAL: /* eval */
-+          if(cdr(sc->args)!=sc->NIL) {
-+               sc->envir=cadr(sc->args);
-+          }
-+          sc->code = car(sc->args);
-+          s_goto(sc,OP_EVAL);
-+
-+     case OP_CONTINUATION:    /* call-with-current-continuation */
-+          sc->code = car(sc->args);
-+          sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
-+          s_goto(sc,OP_APPLY);
-+
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+     }
-+     return sc->T;
-+}
-+
-+static pointer opexe_2(scheme *sc, enum scheme_opcodes op) {
-+     pointer x;
-+     num v;
-+#if USE_MATH
-+     double dd;
-+#endif
-+
-+     switch (op) {
-+#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)));
-+       }
-+       s_return(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)));
-+       }
-+       s_return(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)));
-+       }
-+       s_return(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");
-+         }
-+       }
-+       s_return(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");
-+               }
-+          }
-+          s_return(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");
-+          }
-+          s_return(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");
-+          }
-+          s_return(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));
-+          s_return(sc,mk_integer(sc,(unsigned char)c));
-+     }
-+
-+     case OP_INT2CHAR: { /* integer->char */
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_CHARUPCASE: {
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          c=toupper(c);
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_CHARDNCASE: {
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          c=tolower(c);
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_STR2SYM:  /* string->symbol */
-+          s_return(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 */
-+          x=mk_string(sc,symname(car(sc->args)));
-+          setimmutable(x);
-+          s_return(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);
-+            s_return(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));
-+          }
-+          s_return(sc,mk_empty_string(sc,len,(char)fill));
-+     }
-+
-+     case OP_STRLEN:  /* string-length */
-+          s_return(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));
-+          }
-+
-+          s_return(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));
-+       }
-+       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(sc, newstr);
-+     }
-+
-+     case OP_SUBSTR: { /* substring */
-+          char *str;
-+          int index0;
-+          int index1;
-+          int len;
-+
-+          str=strvalue(car(sc->args));
-+
-+          index0=ivalue(cadr(sc->args));
-+
-+          if(index0>strlength(car(sc->args))) {
-+               Error_1(sc,"substring: start out of bounds:",cadr(sc->args));
-+          }
-+
-+          if(cddr(sc->args)!=sc->NIL) {
-+               index1=ivalue(caddr(sc->args));
-+               if(index1>strlength(car(sc->args)) || index1<index0) {
-+                    Error_1(sc,"substring: end out of bounds:",caddr(sc->args));
-+               }
-+          } else {
-+               index1=strlength(car(sc->args));
-+          }
-+
-+          len=index1-index0;
-+          x=mk_empty_string(sc,len,' ');
-+          memcpy(strvalue(x),str+index0,len);
-+          strvalue(x)[len]=0;
-+
-+          s_return(sc,x);
-+     }
-+
-+     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 */
-+          s_return(sc,mk_integer(sc,ivalue(car(sc->args))));
-+
-+     case OP_VECREF: { /* vector-ref */
-+          int index;
-+
-+          index=ivalue(cadr(sc->args));
-+
-+          if(index>=ivalue(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>=ivalue(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));
-+     }
-+
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+     }
-+     return sc->T;
-+}
-+
-+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;
-+        }
-+    }
-+}
-+
-+static pointer opexe_3(scheme *sc, enum scheme_opcodes op) {
-+     pointer x;
-+     num v;
-+     int (*comp_func)(num,num)=0;
-+
-+     switch (op) {
-+     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:      /* = */
-+     case OP_LESS:       /* < */
-+     case OP_GRE:        /* > */
-+     case OP_LEQ:        /* <= */
-+     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;
-+          }
-+          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)));
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+     }
-+     return sc->T;
-+}
-+
-+static pointer opexe_4(scheme *sc, enum scheme_opcodes op) {
-+     pointer x, y;
-+
-+     switch (op) {
-+     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_goto(sc,OP_APPLY);
-+          } else {
-+               s_return(sc,sc->code);
-+          }
-+
-+     case OP_SAVE_FORCED:     /* Save forced value replacing promise */
-+          memcpy(sc->code,sc->value,sizeof(struct cell));
-+          s_return(sc,sc->value);
-+
-+     case OP_WRITE:      /* write */
-+     case OP_DISPLAY:    /* display */
-+     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_goto(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_goto(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_goto(sc,OP_P0LIST);
-+          } else {
-+               putstr(sc, "\n");
-+               if(sc->interactive_repl) {
-+                    s_goto(sc,OP_T0LVL);
-+               } else {
-+                    return sc->NIL;
-+               }
-+          }
-+
-+     case OP_REVERSE:   /* reverse */
-+          s_return(sc,reverse(sc, 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_PUT:        /* put */
-+          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-+               Error_0(sc,"illegal use of put");
-+          }
-+          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-+               if (caar(x) == y) {
-+                    break;
-+               }
-+          }
-+          if (x != sc->NIL)
-+               cdar(x) = caddr(sc->args);
-+          else
-+               symprop(car(sc->args)) = cons(sc, cons(sc, y, caddr(sc->args)),
-+                                symprop(car(sc->args)));
-+          s_return(sc,sc->T);
-+
-+     case OP_GET:        /* get */
-+          if (!hasprop(car(sc->args)) || !hasprop(cadr(sc->args))) {
-+               Error_0(sc,"illegal use of get");
-+          }
-+          for (x = symprop(car(sc->args)), y = cadr(sc->args); x != sc->NIL; x = cdr(x)) {
-+               if (caar(x) == y) {
-+                    break;
-+               }
-+          }
-+          if (x != sc->NIL) {
-+               s_return(sc,cdar(x));
-+          } else {
-+               s_return(sc,sc->NIL);
-+          }
-+#endif /* USE_PLIST */
-+     case OP_QUIT:       /* quit */
-+          if(is_pair(sc->args)) {
-+               sc->retcode=ivalue(car(sc->args));
-+          }
-+          return (sc->NIL);
-+
-+     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 */
-+     case OP_OPEN_OUTFILE: /* open-output-file */
-+     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;
-+          }
-+          p=port_from_filename(sc,strvalue(car(sc->args)),prop);
-+          if(p==sc->NIL) {
-+               s_return(sc,sc->F);
-+          }
-+          s_return(sc,p);
-+     }
-+
-+#if USE_STRING_PORTS
-+     case OP_OPEN_INSTRING: /* open-input-string */
-+     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;
-+          }
-+          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) {
-+               off_t size;
-+               char *str;
-+
-+               size=p->rep.string.curr-p->rep.string.start+1;
-+               str=sc->malloc(size);
-+               if(str != NULL) {
-+                    pointer s;
-+
-+                    memcpy(str,p->rep.string.start,size-1);
-+                    str[size-1]='\0';
-+                    s=mk_string(sc,str);
-+                    sc->free(str);
-+                    s_return(sc,s);
-+               }
-+          }
-+          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);
-+
-+     }
-+     return sc->T;
-+}
-+
-+static pointer opexe_5(scheme *sc, enum scheme_opcodes op) {
-+     pointer x;
-+
-+     if(sc->nesting!=0) {
-+          int n=sc->nesting;
-+          sc->nesting=0;
-+          sc->retcode=-1;
-+          Error_1(sc,"unmatched parentheses:",mk_integer(sc,n));
-+     }
-+
-+     switch (op) {
-+     /* ========== reading part ========== */
-+     case OP_READ:
-+          if(!is_pair(sc->args)) {
-+               s_goto(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_goto(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_goto(sc,OP_READ_INTERNAL);
-+
-+     case OP_READ_CHAR: /* read-char */
-+     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(sc->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 */
-+/*
-+ * Commented out because we now skip comments in the scanner
-+ *
-+          case TOK_COMMENT: {
-+               int c;
-+               while ((c=inchar(sc)) != '\n' && c!=EOF)
-+                    ;
-+               sc->tok = token(sc);
-+               s_goto(sc,OP_RDSEXPR);
-+          }
-+*/
-+          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 {
-+                    sc->nesting_stack[sc->file_i]++;
-+                    s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
-+                    s_goto(sc,OP_RDSEXPR);
-+               }
-+          case TOK_QUOTE:
-+               s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
-+               sc->tok = token(sc);
-+               s_goto(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_goto(sc,OP_RDSEXPR);
-+               } else {
-+                 s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
-+               }
-+               s_goto(sc,OP_RDSEXPR);
-+          case TOK_COMMA:
-+               s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
-+               sc->tok = token(sc);
-+               s_goto(sc,OP_RDSEXPR);
-+          case TOK_ATMARK:
-+               s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
-+               sc->tok = token(sc);
-+               s_goto(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_goto(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: {
-+          sc->args = cons(sc, sc->value, sc->args);
-+          sc->tok = token(sc);
-+/* We now skip comments in the scanner
-+          while (sc->tok == TOK_COMMENT) {
-+               int c;
-+               while ((c=inchar(sc)) != '\n' && c!=EOF)
-+                    ;
-+               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);
-+#if SHOW_ERROR_LINE
-+               else if (sc->load_stack[sc->file_i].kind & port_file)
-+                  sc->load_stack[sc->file_i].rep.stdio.curr_line++;
-+#endif
-+               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_goto(sc,OP_RDSEXPR);
-+          } else {
-+               s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
-+               s_goto(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:
-+          s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));
-+
-+     case OP_RDQQUOTE:
-+          s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));
-+
-+     case OP_RDQQUOTEVEC:
-+           s_return(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:
-+          s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));
-+
-+     case OP_RDUQTSP:
-+          s_return(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_goto(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_goto(sc,OP_APPLY);*/
-+          sc->args=sc->value;
-+          s_goto(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_goto(sc,OP_PVECFROM);
-+          } else if(is_environment(sc->args)) {
-+               putstr(sc,"#<ENVIRONMENT>");
-+               s_return(sc,sc->T);
-+          } else if (!is_pair(sc->args)) {
-+               printatom(sc, sc->args, sc->print_flag);
-+               s_return(sc,sc->T);
-+          } else if (car(sc->args) == sc->QUOTE && ok_abbrev(cdr(sc->args))) {
-+               putstr(sc, "'");
-+               sc->args = cadr(sc->args);
-+               s_goto(sc,OP_P0LIST);
-+          } else if (car(sc->args) == sc->QQUOTE && ok_abbrev(cdr(sc->args))) {
-+               putstr(sc, "`");
-+               sc->args = cadr(sc->args);
-+               s_goto(sc,OP_P0LIST);
-+          } else if (car(sc->args) == sc->UNQUOTE && ok_abbrev(cdr(sc->args))) {
-+               putstr(sc, ",");
-+               sc->args = cadr(sc->args);
-+               s_goto(sc,OP_P0LIST);
-+          } else if (car(sc->args) == sc->UNQUOTESP && ok_abbrev(cdr(sc->args))) {
-+               putstr(sc, ",@");
-+               sc->args = cadr(sc->args);
-+               s_goto(sc,OP_P0LIST);
-+          } else {
-+               putstr(sc, "(");
-+               s_save(sc,OP_P1LIST, cdr(sc->args), sc->NIL);
-+               sc->args = car(sc->args);
-+               s_goto(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_goto(sc,OP_P0LIST);
-+          } else if(is_vector(sc->args)) {
-+            s_save(sc,OP_P1LIST,sc->NIL,sc->NIL);
-+            putstr(sc, " . ");
-+            s_goto(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=ivalue_unchecked(vec);
-+          if(i==len) {
-+               putstr(sc,")");
-+               s_return(sc,sc->T);
-+          } else {
-+               pointer elem=vector_elem(vec,i);
-+               ivalue_unchecked(cdr(sc->args))=i+1;
-+               s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
-+               sc->args=elem;
-+               if (i > 0)
-+                   putstr(sc," ");
-+               s_goto(sc,OP_P0LIST);
-+          }
-+     }
-+
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+
-+     }
-+     return sc->T;
-+}
-+
-+static pointer opexe_6(scheme *sc, enum scheme_opcodes op) {
-+     pointer x, y;
-+     long v;
-+
-+     switch (op) {
-+     case OP_LIST_LENGTH:     /* length */   /* a.k */
-+          v=list_length(sc,car(sc->args));
-+          if(v<0) {
-+               Error_1(sc,"length: not a list:",car(sc->args));
-+          }
-+          s_return(sc,mk_integer(sc, v));
-+
-+     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)) {
-+               s_return(sc,cons(sc, sc->LAMBDA, closure_code(sc->value)));
-+          } else if (is_macro(sc->args)) {
-+               s_return(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)));
-+     default:
-+          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
-+          Error_0(sc,sc->strbuff);
-+     }
-+     return sc->T; /* NOTREACHED */
-+}
-+
-+typedef pointer (*dispatch_func)(scheme *, enum scheme_opcodes);
-+
-+typedef int (*test_predicate)(pointer);
-+static int is_any(pointer p) { return 1;}
-+
-+static int is_nonneg(pointer p) {
-+  return ivalue(p)>=0 && is_integer(p);
-+}
-+
-+/* Correspond carefully with following defines! */
-+static 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"
-+
-+typedef struct {
-+  dispatch_func func;
-+  char *name;
-+  int min_arity;
-+  int max_arity;
-+  char *arg_tests_encoding;
-+} op_code_info;
-+
-+#define INF_ARG 0xffff
-+
-+static op_code_info dispatch_table[]= {
-+#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
-+#include "opdefines.h"
-+  { 0 }
-+};
-+
-+static const char *procname(pointer x) {
-+ int n=procnum(x);
-+ const char *name=dispatch_table[n].name;
-+ if(name==0) {
-+     name="ILLEGAL!";
-+ }
-+ return name;
-+}
-+
-+/* kernel of this interpreter */
-+static void Eval_Cycle(scheme *sc, enum scheme_opcodes op) {
-+  sc->op = op;
-+  for (;;) {
-+    op_code_info *pcd=dispatch_table+sc->op;
-+    if (pcd->name!=0) { /* if built-in function, check arguments */
-+      char msg[STRBUFFSIZE];
-+      int ok=1;
-+      int n=list_length(sc,sc->args);
-+
-+      /* Check number of arguments */
-+      if(n<pcd->min_arity) {
-+        ok=0;
-+        snprintf(msg, STRBUFFSIZE, "%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, STRBUFFSIZE, "%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) {
-+          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) {/* last test is replicated as necessary */
-+              t++;
-+            }
-+            arglist=cdr(arglist);
-+            i++;
-+          } while(i<n);
-+          if(i<n) {
-+            ok=0;
-+            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
-+                pcd->name,
-+                i+1,
-+                tests[j].kind);
-+          }
-+        }
-+      }
-+      if(!ok) {
-+        if(_Error_1(sc,msg,0)==sc->NIL) {
-+          return;
-+        }
-+        pcd=dispatch_table+sc->op;
-+      }
-+    }
-+    ok_to_freely_gc(sc);
-+    if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
-+      return;
-+    }
-+    if(sc->no_memory) {
-+      fprintf(stderr,"No memory!\n");
-+      return;
-+    }
-+  }
-+}
-+
-+/* ========== Initialization of internal keywords ========== */
-+
-+static void assign_syntax(scheme *sc, char *name) {
-+     pointer x;
-+
-+     x = oblist_add_by_name(sc, name);
-+     typeflag(x) |= T_SYNTAX;
-+}
-+
-+static void assign_proc(scheme *sc, enum scheme_opcodes op, 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;
-+}
-+
-+/* Hard-coded for the given keywords. Remember to rewrite if more are added! */
-+static int syntaxnum(pointer p) {
-+     const char *s=strvalue(car(p));
-+     switch(strlength(car(p))) {
-+     case 2:
-+          if(s[0]=='i') return OP_IF0;        /* if */
-+          else return OP_OR0;                 /* or */
-+     case 3:
-+          if(s[0]=='a') return OP_AND0;      /* and */
-+          else return OP_LET0;               /* let */
-+     case 4:
-+          switch(s[3]) {
-+          case 'e': return OP_CASE0;         /* case */
-+          case 'd': return OP_COND0;         /* cond */
-+          case '*': return OP_LET0AST;       /* let* */
-+          default: return OP_SET0;           /* set! */
-+          }
-+     case 5:
-+          switch(s[2]) {
-+          case 'g': return OP_BEGIN;         /* begin */
-+          case 'l': return OP_DELAY;         /* delay */
-+          case 'c': return OP_MACRO0;        /* macro */
-+          default: return OP_QUOTE;          /* quote */
-+          }
-+     case 6:
-+          switch(s[2]) {
-+          case 'm': return OP_LAMBDA;        /* lambda */
-+          case 'f': return OP_DEF0;          /* define */
-+          default: return OP_LET0REC;        /* letrec */
-+          }
-+     default:
-+          return OP_C0STREAM;                /* cons-stream */
-+     }
-+}
-+
-+/* 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 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,
-+  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
-+};
-+#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;
-+
-+  num_zero.is_fixnum=1;
-+  num_zero.value.ivalue=0;
-+  num_one.is_fixnum=1;
-+  num_one.value.ivalue=1;
-+
-+#if USE_INTERFACE
-+  sc->vptr=&vtbl;
-+#endif
-+  sc->gensym_cnt=0;
-+  sc->malloc=malloc;
-+  sc->free=free;
-+  sc->last_cell_seg = -1;
-+  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->no_memory=0;
-+  sc->inport=sc->NIL;
-+  sc->outport=sc->NIL;
-+  sc->save_inport=sc->NIL;
-+  sc->loadport=sc->NIL;
-+  sc->nesting=0;
-+  sc->interactive_repl=0;
-+
-+  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;
-+
-+  /* init sc->NIL */
-+  typeflag(sc->NIL) = (T_ATOM | MARK);
-+  car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
-+  /* init T */
-+  typeflag(sc->T) = (T_ATOM | MARK);
-+  car(sc->T) = cdr(sc->T) = sc->T;
-+  /* init F */
-+  typeflag(sc->F) = (T_ATOM | MARK);
-+  car(sc->F) = cdr(sc->F) = sc->F;
-+  /* init sink */
-+  typeflag(sc->sink) = (T_PAIR | MARK);
-+  car(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, "lambda");
-+  assign_syntax(sc, "quote");
-+  assign_syntax(sc, "define");
-+  assign_syntax(sc, "if");
-+  assign_syntax(sc, "begin");
-+  assign_syntax(sc, "set!");
-+  assign_syntax(sc, "let");
-+  assign_syntax(sc, "let*");
-+  assign_syntax(sc, "letrec");
-+  assign_syntax(sc, "cond");
-+  assign_syntax(sc, "delay");
-+  assign_syntax(sc, "and");
-+  assign_syntax(sc, "or");
-+  assign_syntax(sc, "cons-stream");
-+  assign_syntax(sc, "macro");
-+  assign_syntax(sc, "case");
-+
-+  for(i=0; i<n; i++) {
-+    if(dispatch_table[i].name!=0) {
-+      assign_proc(sc, (enum scheme_opcodes)i, dispatch_table[i].name);
-+    }
-+  }
-+
-+  /* initialization of global pointers to special symbols */
-+  sc->LAMBDA = mk_symbol(sc, "lambda");
-+  sc->QUOTE = mk_symbol(sc, "quote");
-+  sc->QQUOTE = mk_symbol(sc, "quasiquote");
-+  sc->UNQUOTE = mk_symbol(sc, "unquote");
-+  sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
-+  sc->FEED_TO = mk_symbol(sc, "=>");
-+  sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
-+  sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
-+  sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
-+  sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");
-+
-+  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) {
-+  int i;
-+
-+#if SHOW_ERROR_LINE
-+  char *fname;
-+#endif
-+
-+  sc->oblist=sc->NIL;
-+  sc->global_env=sc->NIL;
-+  dump_stack_free(sc);
-+  sc->envir=sc->NIL;
-+  sc->code=sc->NIL;
-+  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;
-+  sc->gc_verbose=0;
-+  gc(sc,sc->NIL,sc->NIL);
-+
-+  for(i=0; i<=sc->last_cell_seg; i++) {
-+    sc->free(sc->alloc_seg[i]);
-+  }
-+
-+#if SHOW_ERROR_LINE
-+  for(i=0; i<=sc->file_i; i++) {
-+    if (sc->load_stack[i].kind & port_file) {
-+      fname = sc->load_stack[i].rep.stdio.filename;
-+      if(fname)
-+        sc->free(fname);
-+    }
-+  }
-+#endif
-+}
-+
-+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;
-+  }
-+
-+#if SHOW_ERROR_LINE
-+  sc->load_stack[0].rep.stdio.curr_line = 0;
-+  if(fin!=stdin && filename)
-+    sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
-+#endif
-+
-+  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;
-+  }
-+}
-+
-+void scheme_load_string(scheme *sc, const char *cmd) {
-+  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*)cmd; /* This func respects const */
-+  sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
-+  sc->load_stack[0].rep.string.curr=(char*)cmd;
-+  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;
-+  }
-+}
-+
-+void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
-+     pointer x;
-+
-+     x=find_slot_in_env(sc,envir,symbol,0);
-+     if (x != sc->NIL) {
-+          set_slot_in_env(sc, x, value);
-+     } else {
-+          new_slot_spec_in_env(sc, envir, symbol, value);
-+     }
-+}
-+
-+#if !STANDALONE
-+void scheme_register_foreign_func(scheme * sc, scheme_registerable * sr)
-+{
-+  scheme_define(sc,
-+                sc->global_env,
-+                mk_symbol(sc,sr->name),
-+                mk_foreign_func(sc, sr->f));
-+}
-+
-+void scheme_register_foreign_func_list(scheme * sc,
-+                                       scheme_registerable * list,
-+                                       int count)
-+{
-+  int i;
-+  for(i = 0; i < count; i++)
-+    {
-+      scheme_register_foreign_func(sc, list + i);
-+    }
-+}
-+
-+pointer scheme_apply0(scheme *sc, const char *procname)
-+{ return scheme_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }
-+
-+void save_from_C_call(scheme *sc)
-+{
-+  pointer saved_data =
-+    cons(sc,
-+         car(sc->sink),
-+         cons(sc,
-+              sc->envir,
-+              sc->dump));
-+  /* Push */
-+  sc->c_nest = cons(sc, saved_data, sc->c_nest);
-+  /* Truncate the dump stack so TS will return here when done, not
-+     directly resume pre-C-call operations. */
-+  dump_stack_reset(sc);
-+}
-+void restore_from_C_call(scheme *sc)
-+{
-+  car(sc->sink) = caar(sc->c_nest);
-+  sc->envir = cadar(sc->c_nest);
-+  sc->dump = cdr(cdar(sc->c_nest));
-+  /* Pop */
-+  sc->c_nest = cdr(sc->c_nest);
-+}
-+
-+/* "func" and "args" are assumed to be already eval'ed. */
-+pointer scheme_call(scheme *sc, pointer func, pointer args)
-+{
-+  int old_repl = sc->interactive_repl;
-+  sc->interactive_repl = 0;
-+  save_from_C_call(sc);
-+  sc->envir = sc->global_env;
-+  sc->args = args;
-+  sc->code = func;
-+  sc->retcode = 0;
-+  Eval_Cycle(sc, OP_APPLY);
-+  sc->interactive_repl = old_repl;
-+  restore_from_C_call(sc);
-+  return sc->value;
-+}
-+
-+pointer scheme_eval(scheme *sc, pointer obj)
-+{
-+  int old_repl = sc->interactive_repl;
-+  sc->interactive_repl = 0;
-+  save_from_C_call(sc);
-+  sc->args = sc->NIL;
-+  sc->code = obj;
-+  sc->retcode = 0;
-+  Eval_Cycle(sc, OP_EVAL);
-+  sc->interactive_repl = old_repl;
-+  restore_from_C_call(sc);
-+  return sc->value;
-+}
-+
-+
-+#endif
-+
-+/* ========== Main ========== */
-+
-+#if STANDALONE
-+
-+#if defined(__APPLE__) && !defined (OSX)
-+int main()
-+{
-+     extern MacTS_main(int argc, char **argv);
-+     char**    argv;
-+     int argc = ccommand(&argv);
-+     MacTS_main(argc,argv);
-+     return 0;
-+}
-+int MacTS_main(int argc, char **argv) {
-+#else
-+int main(int argc, char **argv) {
-+#endif
-+  scheme sc;
-+  FILE *fin;
-+  char *file_name=InitFile;
-+  int retcode;
-+  int isfile=1;
-+
-+  if(argc==1) {
-+    printf(banner);
-+  }
-+  if(argc==2 && strcmp(argv[1],"-?")==0) {
-+    printf("Usage: tinyscheme -?\n");
-+    printf("or:    tinyscheme [<file1> <file2> ...]\n");
-+    printf("followed by\n");
-+    printf("          -1 <file> [<arg1> <arg2> ...]\n");
-+    printf("          -c <Scheme commands> [<arg1> <arg2> ...]\n");
-+    printf("assuming that the executable is named tinyscheme.\n");
-+    printf("Use - as filename for stdin.\n");
-+    return 1;
-+  }
-+  if(!scheme_init(&sc)) {
-+    fprintf(stderr,"Could not initialize!\n");
-+    return 2;
-+  }
-+  scheme_set_input_port_file(&sc, stdin);
-+  scheme_set_output_port_file(&sc, stdout);
-+#if USE_DL
-+  scheme_define(&sc,sc.global_env,mk_symbol(&sc,"load-extension"),mk_foreign_func(&sc, scm_load_ext));
-+#endif
-+  argv++;
-+  if(access(file_name,0)!=0) {
-+    char *p=getenv("TINYSCHEMEINIT");
-+    if(p!=0) {
-+      file_name=p;
-+    }
-+  }
-+  do {
-+    if(strcmp(file_name,"-")==0) {
-+      fin=stdin;
-+    } else if(strcmp(file_name,"-1")==0 || strcmp(file_name,"-c")==0) {
-+      pointer args=sc.NIL;
-+      isfile=file_name[1]=='1';
-+      file_name=*argv++;
-+      if(strcmp(file_name,"-")==0) {
-+        fin=stdin;
-+      } else if(isfile) {
-+        fin=fopen(file_name,"r");
-+      }
-+      for(;*argv;argv++) {
-+        pointer value=mk_string(&sc,*argv);
-+        args=cons(&sc,value,args);
-+      }
-+      args=reverse_in_place(&sc,sc.NIL,args);
-+      scheme_define(&sc,sc.global_env,mk_symbol(&sc,"*args*"),args);
-+
-+    } else {
-+      fin=fopen(file_name,"r");
-+    }
-+    if(isfile && fin==0) {
-+      fprintf(stderr,"Could not open file %s\n",file_name);
-+    } else {
-+      if(isfile) {
-+        scheme_load_named_file(&sc,fin,file_name);
-+      } else {
-+        scheme_load_string(&sc,file_name);
-+      }
-+      if(!isfile || fin!=stdin) {
-+        if(sc.retcode!=0) {
-+          fprintf(stderr,"Errors encountered reading %s\n",file_name);
-+        }
-+        if(isfile) {
-+          fclose(fin);
-+        }
-+      }
-+    }
-+    file_name=*argv++;
-+  } while(file_name!=0);
-+  if(argc==1) {
-+    scheme_load_named_file(&sc,stdin,0);
-+  }
-+  retcode=sc.retcode;
-+  scheme_deinit(&sc);
-+
-+  return retcode;
-+}
-+
-+#endif
-+
-+/*
-+Local variables:
-+c-file-style: "k&r"
-+End:
-+*/
-+
-+/* XXX: Hurd addition.  */
-+void
-+scheme_load_mem (scheme *sc, const char *cmd_start, const char *cmd_end)
-+{
-+  dump_stack_reset(sc);
-+  sc->envir = sc->global_env;
-+  sc->file_i=0;
-+  sc->load_stack[0].kind=port_input|port_string;
-+  /* This func respects const */
-+  sc->load_stack[0].rep.string.start=(char*) cmd_start;
-+  sc->load_stack[0].rep.string.past_the_end=(char*) cmd_end;
-+  sc->load_stack[0].rep.string.curr=(char*) cmd_start;
-+  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;
-+  }
-+}
-diff --git a/bootshell/scheme.h b/bootshell/scheme.h
-new file mode 100644
-index 0000000..fbc542b
---- /dev/null
-+++ b/bootshell/scheme.h
-@@ -0,0 +1,255 @@
-+/* SCHEME.H */
-+
-+#ifndef _SCHEME_H
-+#define _SCHEME_H
-+
-+#include <stdio.h>
-+
-+#ifdef __cplusplus
-+extern "C" {
-+#endif
-+
-+/*
-+ * Default values for #define'd symbols
-+ */
-+#ifndef STANDALONE       /* If used as standalone interpreter */
-+# define STANDALONE 1
-+#endif
-+
-+#ifndef _MSC_VER
-+# define USE_STRCASECMP 1
-+# ifndef USE_STRLWR
-+#   define USE_STRLWR 1
-+# endif
-+# define SCHEME_EXPORT
-+#else
-+# define USE_STRCASECMP 0
-+# define USE_STRLWR 0
-+# ifdef _SCHEME_SOURCE
-+#  define SCHEME_EXPORT __declspec(dllexport)
-+# else
-+#  define SCHEME_EXPORT __declspec(dllimport)
-+# endif
-+#endif
-+
-+#if USE_NO_FEATURES
-+# define USE_MATH 0
-+# define USE_CHAR_CLASSIFIERS 0
-+# define USE_ASCII_NAMES 0
-+# define USE_STRING_PORTS 0
-+# define USE_ERROR_HOOK 0
-+# define USE_TRACING 0
-+# define USE_COLON_HOOK 0
-+# define USE_DL 0
-+# define USE_PLIST 0
-+#endif
-+
-+/*
-+ * Leave it defined if you want continuations, and also for the Sharp Zaurus.
-+ * Undefine it if you only care about faster speed and not strict Scheme compatibility.
-+ */
-+#define USE_SCHEME_STACK
-+
-+#if USE_DL
-+# define USE_INTERFACE 1
-+#endif
-+
-+
-+#ifndef USE_MATH         /* If math support is needed */
-+# define USE_MATH 1
-+#endif
-+
-+#ifndef USE_CHAR_CLASSIFIERS  /* If char classifiers are needed */
-+# define USE_CHAR_CLASSIFIERS 1
-+#endif
-+
-+#ifndef USE_ASCII_NAMES  /* If extended escaped characters are needed */
-+# define USE_ASCII_NAMES 1
-+#endif
-+
-+#ifndef USE_STRING_PORTS      /* Enable string ports */
-+# define USE_STRING_PORTS 1
-+#endif
-+
-+#ifndef USE_TRACING
-+# define USE_TRACING 1
-+#endif
-+
-+#ifndef USE_PLIST
-+# define USE_PLIST 0
-+#endif
-+
-+/* To force system errors through user-defined error handling (see *error-hook*) */
-+#ifndef USE_ERROR_HOOK
-+# define USE_ERROR_HOOK 1
-+#endif
-+
-+#ifndef USE_COLON_HOOK   /* Enable qualified qualifier */
-+# define USE_COLON_HOOK 1
-+#endif
-+
-+#ifndef USE_STRCASECMP   /* stricmp for Unix */
-+# define USE_STRCASECMP 0
-+#endif
-+
-+#ifndef USE_STRLWR
-+# define USE_STRLWR 1
-+#endif
-+
-+#ifndef STDIO_ADDS_CR    /* Define if DOS/Windows */
-+# define STDIO_ADDS_CR 0
-+#endif
-+
-+#ifndef INLINE
-+# define INLINE
-+#endif
-+
-+#ifndef USE_INTERFACE
-+# define USE_INTERFACE 0
-+#endif
-+
-+#ifndef SHOW_ERROR_LINE   /* Show error line in file */
-+# define SHOW_ERROR_LINE 1
-+#endif
-+
-+typedef struct scheme scheme;
-+typedef struct cell *pointer;
-+
-+typedef void * (*func_alloc)(size_t);
-+typedef void (*func_dealloc)(void *);
-+
-+/* num, for generic arithmetic */
-+typedef struct num {
-+     char is_fixnum;
-+     union {
-+          long ivalue;
-+          double rvalue;
-+     } value;
-+} num;
-+
-+SCHEME_EXPORT scheme *scheme_init_new();
-+SCHEME_EXPORT scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free);
-+SCHEME_EXPORT int scheme_init(scheme *sc);
-+SCHEME_EXPORT int scheme_init_custom_alloc(scheme *sc, func_alloc, func_dealloc);
-+SCHEME_EXPORT void scheme_deinit(scheme *sc);
-+void scheme_set_input_port_file(scheme *sc, FILE *fin);
-+void scheme_set_input_port_string(scheme *sc, char *start, char *past_the_end);
-+SCHEME_EXPORT void scheme_set_output_port_file(scheme *sc, FILE *fin);
-+void scheme_set_output_port_string(scheme *sc, char *start, char *past_the_end);
-+SCHEME_EXPORT void scheme_load_file(scheme *sc, FILE *fin);
-+SCHEME_EXPORT void scheme_load_named_file(scheme *sc, FILE *fin, const char *filename);
-+SCHEME_EXPORT void scheme_load_string(scheme *sc, const char *cmd);
-+SCHEME_EXPORT pointer scheme_apply0(scheme *sc, const char *procname);
-+SCHEME_EXPORT pointer scheme_call(scheme *sc, pointer func, pointer args);
-+SCHEME_EXPORT pointer scheme_eval(scheme *sc, pointer obj);
-+void scheme_set_external_data(scheme *sc, void *p);
-+SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value);
-+
-+typedef pointer (*foreign_func)(scheme *, pointer);
-+
-+pointer _cons(scheme *sc, pointer a, pointer b, int immutable);
-+pointer mk_integer(scheme *sc, long num);
-+pointer mk_real(scheme *sc, double num);
-+pointer mk_symbol(scheme *sc, const char *name);
-+pointer gensym(scheme *sc);
-+pointer mk_string(scheme *sc, const char *str);
-+pointer mk_counted_string(scheme *sc, const char *str, int len);
-+pointer mk_empty_string(scheme *sc, int len, char fill);
-+pointer mk_character(scheme *sc, int c);
-+pointer mk_foreign_func(scheme *sc, foreign_func f);
-+void putstr(scheme *sc, const char *s);
-+int list_length(scheme *sc, pointer a);
-+int eqv(pointer a, pointer b);
-+
-+
-+#if USE_INTERFACE
-+struct scheme_interface {
-+  void (*scheme_define)(scheme *sc, pointer env, pointer symbol, pointer value);
-+  pointer (*cons)(scheme *sc, pointer a, pointer b);
-+  pointer (*immutable_cons)(scheme *sc, pointer a, pointer b);
-+  pointer (*reserve_cells)(scheme *sc, int n);
-+  pointer (*mk_integer)(scheme *sc, long num);
-+  pointer (*mk_real)(scheme *sc, double num);
-+  pointer (*mk_symbol)(scheme *sc, const char *name);
-+  pointer (*gensym)(scheme *sc);
-+  pointer (*mk_string)(scheme *sc, const char *str);
-+  pointer (*mk_counted_string)(scheme *sc, const char *str, int len);
-+  pointer (*mk_character)(scheme *sc, int c);
-+  pointer (*mk_vector)(scheme *sc, int len);
-+  pointer (*mk_foreign_func)(scheme *sc, foreign_func f);
-+  void (*putstr)(scheme *sc, const char *s);
-+  void (*putcharacter)(scheme *sc, int c);
-+
-+  int (*is_string)(pointer p);
-+  char *(*string_value)(pointer p);
-+  int (*is_number)(pointer p);
-+  num (*nvalue)(pointer p);
-+  long (*ivalue)(pointer p);
-+  double (*rvalue)(pointer p);
-+  int (*is_integer)(pointer p);
-+  int (*is_real)(pointer p);
-+  int (*is_character)(pointer p);
-+  long (*charvalue)(pointer p);
-+  int (*is_list)(scheme *sc, pointer p);
-+  int (*is_vector)(pointer p);
-+  int (*list_length)(scheme *sc, pointer vec);
-+  long (*vector_length)(pointer vec);
-+  void (*fill_vector)(pointer vec, pointer elem);
-+  pointer (*vector_elem)(pointer vec, int ielem);
-+  pointer (*set_vector_elem)(pointer vec, int ielem, pointer newel);
-+  int (*is_port)(pointer p);
-+
-+  int (*is_pair)(pointer p);
-+  pointer (*pair_car)(pointer p);
-+  pointer (*pair_cdr)(pointer p);
-+  pointer (*set_car)(pointer p, pointer q);
-+  pointer (*set_cdr)(pointer p, pointer q);
-+
-+  int (*is_symbol)(pointer p);
-+  char *(*symname)(pointer p);
-+
-+  int (*is_syntax)(pointer p);
-+  int (*is_proc)(pointer p);
-+  int (*is_foreign)(pointer p);
-+  char *(*syntaxname)(pointer p);
-+  int (*is_closure)(pointer p);
-+  int (*is_macro)(pointer p);
-+  pointer (*closure_code)(pointer p);
-+  pointer (*closure_env)(pointer p);
-+
-+  int (*is_continuation)(pointer p);
-+  int (*is_promise)(pointer p);
-+  int (*is_environment)(pointer p);
-+  int (*is_immutable)(pointer p);
-+  void (*setimmutable)(pointer p);
-+  void (*load_file)(scheme *sc, FILE *fin);
-+  void (*load_string)(scheme *sc, const char *input);
-+};
-+#endif
-+
-+#if !STANDALONE
-+typedef struct scheme_registerable
-+{
-+  foreign_func  f;
-+  const char *  name;
-+}
-+scheme_registerable;
-+
-+void scheme_register_foreign_func_list(scheme * sc,
-+                                       scheme_registerable * list,
-+                                       int n);
-+
-+#endif /* !STANDALONE */
-+
-+#ifdef __cplusplus
-+}
-+#endif
-+
-+#endif
-+
-+
-+/*
-+Local variables:
-+c-file-style: "k&r"
-+End:
-+*/
-diff --git a/bootshell/startup.c b/bootshell/startup.c
-new file mode 100644
-index 0000000..f11919d
---- /dev/null
-+++ b/bootshell/startup.c
-@@ -0,0 +1,489 @@
-+#include <assert.h>
-+#include <errno.h>
-+#include <error.h>
-+#include <hurd.h>
-+#include <hurd/startup.h>
-+#include <mach.h>
-+#include <mach/message.h>
-+#include <mach/mig_support.h>
-+#include <mach/notify.h>
-+#include <pthread.h>
-+#include <stdio.h>
-+#include <string.h>
-+
-+#include "startup_reply_U.h"
-+// eek #include "startup_S.h"
-+// eek #include "fsys_S.h"
-+
-+extern boolean_t startup_server (mach_msg_header_t *, mach_msg_header_t *);
-+extern boolean_t fsys_server (mach_msg_header_t *, mach_msg_header_t *);
-+
-+#include "bootshell.h"
-+#include "ffi.h"
-+
-+/* Handling of `startup_essential_task'.  */
-+
-+static mach_port_t early_startup_port;
-+
-+/* This structure keeps track of each registered essential task.  */
-+struct port_string_tuple
-+  {
-+    struct port_string_tuple *next;
-+    task_t port;
-+    char *name;
-+  };
-+
-+static struct port_string_tuple *essential_tasks;
-+static struct port_string_tuple *registered_tasks;
-+
-+/* Record an essential task in the list.  */
-+static error_t
-+add_tuple (struct port_string_tuple **list, mach_port_t port, const char *name)
-+{
-+  struct port_string_tuple *et;
-+
-+  et = malloc (sizeof *et);
-+  if (et == NULL)
-+    goto out;
-+
-+  et->port = port;
-+  et->name = strdup (name);
-+  if (et->name == NULL)
-+    goto out;
-+
-+  et->next = *list;
-+  *list = et;
-+  return 0;
-+
-+ out:
-+  free (et);
-+  return ENOMEM;
-+}
-+
-+/* fsys_goaway for early-boot /servers/startup.	 */
-+error_t
-+S_fsys_goaway (mach_port_t fsys,
-+		int flags)
-+{
-+  if (fsys != early_startup_port)
-+    return EOPNOTSUPP;
-+  // XXX keep going = 0
-+  return 0;
-+}
-+
-+/* fsys_getroot for early-boot /servers/startup.  */
-+error_t
-+S_fsys_getroot (mach_port_t fsys,
-+		mach_port_t dotdotnode,
-+		uid_t *uids, size_t nuids,
-+		uid_t *gids, size_t ngids,
-+		int flags,
-+		retry_type *do_retry,
-+		char *retry_name,
-+		mach_port_t *ret,
-+		mach_msg_type_name_t *rettype)
-+{
-+  if (fsys != early_startup_port)
-+    return EOPNOTSUPP;
-+
-+  *do_retry = FS_RETRY_NORMAL;
-+  *retry_name = '\0';
-+  *ret = early_startup_port;
-+  *rettype = MACH_MSG_TYPE_MAKE_SEND;
-+  return 0;
-+}
-+
-+error_t
-+S_startup_essential_task (startup_t server,
-+			  mach_port_t reply_port,
-+			  mach_msg_type_name_t reply_portPoly,
-+			  mach_port_t task,
-+			  mach_port_t excpt,
-+			  string_t name,
-+			  mach_port_t credential)
-+{
-+  error_t err;
-+  if (server != early_startup_port)
-+    return EOPNOTSUPP;
-+  if (credential != _hurd_host_priv)
-+    return EPERM;
-+
-+  err = mach_port_deallocate (mach_task_self (), credential);
-+  assert_perror (err);
-+
-+  if (MACH_PORT_VALID (excpt))
-+    {
-+      error (0, 0,
-+	     "Oh dear, someone actually send us their exception port.\n"
-+	     "I'm going to destroy it.	Please investigate.");
-+      err = mach_port_destroy (mach_task_self (), excpt);
-+      assert_perror (err);
-+    }
-+
-+  err = add_tuple (&essential_tasks, task, name);
-+  if (err)
-+    return err;
-+
-+  return 0;
-+}
-+
-+kern_return_t
-+S_startup_request_notification (mach_port_t server,
-+				mach_port_t notify,
-+				char *name)
-+{
-+  if (server != early_startup_port)
-+    return EOPNOTSUPP;
-+
-+  return add_tuple (&registered_tasks, notify, name);
-+}
-+
-+static boolean_t
-+early_startup_demuxer (mach_msg_header_t *request,
-+				mach_msg_header_t *reply)
-+{
-+  /* XXX hardcoded msgh_ids */
-+  switch (request->msgh_id)
-+    {
-+    case 29000:	/* startup_essential_task */
-+    case 29001:	/* startup_request_notification */
-+      return startup_server (request, reply);
-+    case 22001:	/* fsys_goaway */
-+    case 22002:	/* fsys_getroot */
-+      return fsys_server (request, reply);
-+    }
-+
-+  /* Return MIG_BAD_ID.	 */
-+  mig_reply_setup (request, reply);
-+  return FALSE;
-+}
-+
-+static void *
-+service_early_startup_requests (void *arg)
-+{
-+  // XXX while (keep_going) ...
-+  while (1)
-+    mach_msg_server (early_startup_demuxer, 0,
-+		     early_startup_port);
-+
-+  /* Not reached.  */
-+  return NULL;
-+}
-+
-+static error_t
-+start_handling_early_startup (mach_port_t startup_port)
-+{
-+  error_t err;
-+  pthread_t t;
-+
-+  if (MACH_PORT_VALID (early_startup_port))
-+    return EINVAL;
-+  early_startup_port = startup_port;
-+
-+  /* Make a thread to service `startup_essential_task' requests.  */
-+  err = pthread_create (&t, NULL, service_early_startup_requests,
-+			NULL);
-+  if (err)
-+    return err;
-+  pthread_detach (t);
-+
-+  return err;
-+}
-+
-+pointer
-+do_start_handling_early_startup (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("start-handling-early-startup");
-+  SC_ARG (sc, mach_port_t, server_port, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = start_handling_early_startup (server_port);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_get_essential_tasks (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("get-essential-tasks");
-+  SC_ARGS_DONE (sc);
-+  pointer result = sc->NIL;
-+  struct port_string_tuple *et;
-+  for (et = essential_tasks; et; et = et->next)
-+#define IMC(A, B)	_cons (sc, (A), (B), 1)
-+    result = IMC (IMC (mk_integer (sc, et->port),
-+		       mk_string (sc, et->name)),
-+		  result);
-+#undef IMC
-+  SC_RETURN_POINTER (sc, result);
-+}
-+
-+pointer
-+do_get_registered_tasks (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("get-registered-tasks");
-+  SC_ARGS_DONE (sc);
-+  pointer result = sc->NIL;
-+  struct port_string_tuple *rt;
-+  for (rt = registered_tasks; rt; rt = rt->next)
-+#define IMC(A, B)	_cons (sc, (A), (B), 1)
-+    result = IMC (IMC (mk_integer (sc, rt->port),
-+		       mk_string (sc, rt->name)),
-+		  result);
-+#undef IMC
-+  SC_RETURN_POINTER (sc, result);
-+}
-+
-+/* Client stubs for startup.  */
-+pointer
-+do_startup_essential_task (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("startup-essential-task");
-+  SC_ARG (sc, mach_port_t, startup, number, args);
-+  SC_ARG (sc, mach_port_t, task, number, args);
-+  SC_ARG (sc, mach_port_t, exception, number, args);
-+  SC_ARG (sc, char *, name, string, args);
-+  SC_ARG (sc, mach_port_t, credential, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = startup_essential_task (startup, task, exception, name, credential);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_startup_request_notification (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("startup-request-notification");
-+  SC_ARG (sc, mach_port_t, startup, number, args);
-+  SC_ARG (sc, mach_port_t, notify_port, number, args);
-+  SC_ARG (sc, char *, name, string, args);
-+  SC_ARGS_DONE (sc);
-+  err = startup_request_notification (startup,
-+				      notify_port, MACH_MSG_TYPE_COPY_SEND,
-+				      name);
-+  SC_RETURN (sc);
-+}
-+
-+pointer
-+do_startup_reboot (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("startup-reboot");
-+  SC_ARG (sc, mach_port_t, startup, number, args);
-+  SC_ARG (sc, mach_port_t, credential, number, args);
-+  SC_ARG (sc, int, flags, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = startup_reboot (startup, credential, flags);
-+  SC_RETURN (sc);
-+}
-+
-+/* Handling of `startup_procinit'.  */
-+
-+/* XXX would be nice not to use a global variable, maybe with
-+   payloads.  */
-+static struct
-+{
-+  /* Filled by caller.	*/
-+  mach_port_t bootstrap_port;
-+
-+  /* Filled by the server function.  */
-+  mach_port_t reply;
-+  mach_msg_type_name_t replyPoly;
-+  process_t procserver;
-+} startup_procinit_args;
-+
-+kern_return_t
-+S_startup_procinit (startup_t bootstrap,
-+		    mach_port_t reply,
-+		    mach_msg_type_name_t replyPoly,
-+		    process_t procserver,
-+		    mach_port_t *startuptask,
-+		    auth_t *auth,
-+		    mach_port_t *hostpriv,
-+		    mach_msg_type_name_t *hostprivPoly,
-+		    mach_port_t *devmaster,
-+		    mach_msg_type_name_t *devmasterPoly)
-+{
-+  if (bootstrap != startup_procinit_args.bootstrap_port)
-+    return EOPNOTSUPP;
-+
-+  startup_procinit_args.reply = reply;
-+  startup_procinit_args.replyPoly = replyPoly;
-+  startup_procinit_args.procserver = procserver;
-+  return MIG_NO_REPLY;
-+}
-+
-+boolean_t
-+startup_procinit_demuxer (mach_msg_header_t *request,
-+			  mach_msg_header_t *reply)
-+{
-+  if (request->msgh_id != 29003) /* XXX hardcoded msgh_id */
-+    {
-+      /* Return MIG_BAD_ID.  */
-+      mig_reply_setup (request, reply);
-+      return FALSE;
-+    }
-+  return startup_server (request, reply);
-+}
-+
-+error_t
-+service_startup_procinit_request (mach_port_t bootstrap,
-+				  mach_msg_timeout_t timeout,
-+				  mach_port_t *reply,
-+				  mach_msg_type_name_t *replyPoly,
-+				  process_t *procserver)
-+{
-+  error_t err;
-+
-+  if (! MACH_PORT_VALID (bootstrap))
-+    return EINVAL;
-+
-+  startup_procinit_args.bootstrap_port = bootstrap;
-+
-+  err = mach_msg_server_timeout_once (startup_procinit_demuxer, 0, bootstrap,
-+                                      MACH_RCV_TIMEOUT | MACH_SEND_TIMEOUT,
-+                                      timeout);
-+  if (err != MACH_MSG_SUCCESS)
-+    return err;
-+
-+  *reply = startup_procinit_args.reply;
-+  *replyPoly = startup_procinit_args.replyPoly;
-+  *procserver = startup_procinit_args.procserver;
-+  return 0;
-+}
-+
-+pointer
-+do_handle_startup_procinit (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("handle-startup-procinit");
-+  SC_ARG (sc, mach_port_t, bootstrap, number, args);
-+  SC_ARG (sc, mach_msg_timeout_t, timeout, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t reply;
-+  mach_msg_type_name_t replyPoly;
-+  mach_port_t proc;
-+  err = service_startup_procinit_request (bootstrap, timeout,
-+					  &reply, &replyPoly, &proc);
-+#define IMC(A, B)	_cons (sc, sc->vptr->mk_integer (sc, A), (B), 1)
-+  SC_RETURN_POINTER (sc, IMC (reply, IMC (replyPoly, IMC (proc, sc->NIL))));
-+#undef IMC
-+}
-+
-+pointer
-+do_startup_procinit_reply (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("startup-procinit-reply");
-+  SC_ARG (sc, mach_port_t, reply, number, args);
-+  SC_ARG (sc, mach_msg_type_name_t, replyPoly, number, args);
-+  SC_ARG (sc, int, retCode, number, args);
-+  SC_ARG (sc, mach_port_t, startup_task, number, args);
-+  SC_ARG (sc, mach_port_t, authserver, number, args);
-+  SC_ARG (sc, mach_port_t, host_priv, number, args);
-+  SC_ARG (sc, mach_port_t, device_master, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = startup_procinit_reply (reply, replyPoly, retCode,
-+				startup_task, authserver,
-+				host_priv, MACH_MSG_TYPE_COPY_SEND,
-+				device_master, MACH_MSG_TYPE_COPY_SEND);
-+  SC_RETURN (sc);
-+}
-+
-+/* Handling of `startup_authinit'.  */
-+
-+/* XXX would be nice not to use a global variable, maybe with
-+   payloads.  */
-+static struct
-+{
-+  /* Filled by caller.	*/
-+  mach_port_t bootstrap_port;
-+
-+  /* Filled by the server function.  */
-+  mach_port_t reply;
-+  mach_msg_type_name_t replyPoly;
-+  mach_port_t authserver;
-+} startup_authinit_args;
-+
-+/* Called by the auth server when it starts up.	 */
-+
-+kern_return_t
-+S_startup_authinit (startup_t bootstrap,
-+		    mach_port_t reply,
-+		    mach_msg_type_name_t replyPoly,
-+		    mach_port_t auth,
-+		    mach_port_t *proc,
-+		    mach_msg_type_name_t *procPoly)
-+{
-+  if (bootstrap != startup_authinit_args.bootstrap_port)
-+    return EOPNOTSUPP;
-+
-+  startup_authinit_args.reply = reply;
-+  startup_authinit_args.replyPoly = replyPoly;
-+  startup_authinit_args.authserver = auth;
-+  return MIG_NO_REPLY;
-+}
-+
-+boolean_t
-+startup_authinit_demuxer (mach_msg_header_t *request,
-+			  mach_msg_header_t *reply)
-+{
-+  if (request->msgh_id != 29004) /* XXX hardcoded msgh_id */
-+    {
-+      /* Return MIG_BAD_ID.  */
-+      mig_reply_setup (request, reply);
-+      return FALSE;
-+    }
-+  return startup_server (request, reply);
-+}
-+
-+error_t
-+service_startup_authinit_request (mach_port_t bootstrap,
-+				  mach_msg_timeout_t timeout,
-+				  mach_port_t *reply,
-+				  mach_msg_type_name_t *replyPoly,
-+				  mach_port_t *authserver)
-+{
-+  error_t err;
-+
-+  if (! MACH_PORT_VALID (bootstrap))
-+    return EINVAL;
-+
-+  startup_authinit_args.bootstrap_port = bootstrap;
-+
-+  err = mach_msg_server_timeout_once (startup_authinit_demuxer, 0, bootstrap,
-+				      MACH_RCV_TIMEOUT | MACH_SEND_TIMEOUT,
-+				      timeout);
-+  if (err != MACH_MSG_SUCCESS)
-+    return err;
-+
-+  *reply = startup_authinit_args.reply;
-+  *replyPoly = startup_authinit_args.replyPoly;
-+  *authserver = startup_authinit_args.authserver;
-+  return 0;
-+}
-+
-+pointer
-+do_handle_startup_authinit (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("handle-startup-authinit");
-+  SC_ARG (sc, mach_port_t, bootstrap, number, args);
-+  SC_ARG (sc, mach_msg_timeout_t, timeout, number, args);
-+  SC_ARGS_DONE (sc);
-+  mach_port_t reply;
-+  mach_msg_type_name_t replyPoly;
-+  mach_port_t auth;
-+  err = service_startup_authinit_request (bootstrap, timeout,
-+					  &reply, &replyPoly, &auth);
-+#define IMC(A, B)	_cons (sc, sc->vptr->mk_integer (sc, A), (B), 1)
-+  SC_RETURN_POINTER (sc, IMC (reply, IMC (replyPoly, IMC (auth, sc->NIL))));
-+#undef IMC
-+}
-+
-+pointer
-+do_startup_authinit_reply (scheme *sc, pointer args)
-+{
-+  SC_FFI_PROLOG ("startup-authinit-reply");
-+  SC_ARG (sc, mach_port_t, reply, number, args);
-+  SC_ARG (sc, mach_msg_type_name_t, replyPoly, number, args);
-+  SC_ARG (sc, int, retCode, number, args);
-+  SC_ARG (sc, mach_port_t, authproc, number, args);
-+  SC_ARGS_DONE (sc);
-+  err = startup_authinit_reply (reply, replyPoly, retCode, authproc,
-+				MACH_MSG_TYPE_COPY_SEND);
-+  SC_RETURN (sc);
-+}
-diff --git a/bootshell/startup.h b/bootshell/startup.h
-new file mode 100644
-index 0000000..2dc2367
---- /dev/null
-+++ b/bootshell/startup.h
-@@ -0,0 +1,12 @@
-+#include <ffi.h>
-+
-+pointer do_handle_startup_procinit (scheme *sc, pointer args);
-+pointer do_handle_startup_authinit (scheme *sc, pointer args);
-+pointer do_startup_procinit_reply (scheme *sc, pointer args);
-+pointer do_startup_authinit_reply (scheme *sc, pointer args);
-+pointer do_start_handling_early_startup (scheme *sc, pointer args);
-+pointer do_get_essential_tasks (scheme *sc, pointer args);
-+pointer do_get_registered_tasks (scheme *sc, pointer args);
-+pointer do_startup_essential_task (scheme *sc, pointer args);
-+pointer do_startup_request_notification (scheme *sc, pointer args);
-+pointer do_startup_reboot (scheme *sc, pointer args);
-diff --git a/bootshell/utils.c b/bootshell/utils.c
-new file mode 100644
-index 0000000..8033fb1
---- /dev/null
-+++ b/bootshell/utils.c
-@@ -0,0 +1,118 @@
-+#include <assert.h>
-+#include <hurd.h>
-+#include <mach.h>
-+#include <mach/message.h>
-+#include <stdarg.h>
-+#include <stdio.h>
-+
-+mach_msg_return_t
-+mach_msg_server_timeout_once (boolean_t (*demux) (mach_msg_header_t *request,
-+						  mach_msg_header_t *reply),
-+			      mach_msg_size_t max_size,
-+			      mach_port_t rcv_name,
-+			      mach_msg_option_t option,
-+			      mach_msg_timeout_t timeout)
-+{
-+  mig_reply_header_t *request, *reply;
-+  mach_msg_return_t mr;
-+
-+  if (! MACH_PORT_VALID (rcv_name))
-+    return EINVAL;
-+
-+  if (max_size == 0)
-+    {
-+#ifdef MACH_RCV_LARGE
-+      option |= MACH_RCV_LARGE;
-+      max_size = 2 * __vm_page_size; /* Generic.  Good? XXX */
-+#else
-+      max_size = 4 * __vm_page_size; /* XXX */
-+#endif
-+    }
-+
-+  request = alloca (max_size);
-+  reply = alloca (max_size);
-+
-+  mr = mach_msg (&request->Head, MACH_RCV_MSG|option,
-+		 0, max_size, rcv_name,
-+		 timeout, MACH_PORT_NULL);
-+  if (mr != MACH_MSG_SUCCESS)
-+    return mr;
-+
-+  /* We have a request message.	 Pass it to DEMUX for processing.  */
-+  (void) (*demux) (&request->Head, &reply->Head);
-+  assert (reply->Head.msgh_size <= max_size);
-+
-+  switch (reply->RetCode)
-+    {
-+    case KERN_SUCCESS:
-+      /* Hunky dory.  */
-+      break;
-+
-+    case MIG_NO_REPLY:
-+      /* The server function wanted no reply sent.
-+	 Loop for another request.  */
-+      return 0;
-+
-+    default:
-+      /* Some error; destroy the request message to release any
-+	 port rights or VM it holds.  Don't destroy the reply port
-+	 right, so we can send an error message.  */
-+      request->Head.msgh_remote_port = MACH_PORT_NULL;
-+      mach_msg_destroy (&request->Head);
-+      break;
-+    }
-+
-+  if (reply->Head.msgh_remote_port == MACH_PORT_NULL)
-+    {
-+      /* No reply port, so destroy the reply.  */
-+      if (reply->Head.msgh_bits & MACH_MSGH_BITS_COMPLEX)
-+	mach_msg_destroy (&reply->Head);
-+      return reply->RetCode;
-+    }
-+
-+  /* Send the reply.  */
-+  mr = mach_msg (&reply->Head,
-+		 MACH_SEND_MSG|option,
-+		 reply->Head.msgh_size, max_size, rcv_name,
-+		 timeout, MACH_PORT_NULL);
-+
-+  /* See if a message error occurred.  */
-+  if (mr == MACH_SEND_INVALID_DEST)
-+    /* The reply can't be delivered, so destroy it.  This error
-+       indicates only that the requester went away, so we
-+       continue and get the next request.  */
-+    mach_msg_destroy (&request->Head);
-+
-+  return mr != 0 ? mr : request->RetCode;
-+}
-+
-+/* Fill in default response.  */
-+void
-+mig_reply_setup (
-+	const mach_msg_header_t	*in,
-+	mach_msg_header_t	*out)
-+{
-+      static const mach_msg_type_t RetCodeType = {
-+		/* msgt_name = */		MACH_MSG_TYPE_INTEGER_32,
-+		/* msgt_size = */		32,
-+		/* msgt_number = */		1,
-+		/* msgt_inline = */		TRUE,
-+		/* msgt_longform = */		FALSE,
-+		/* msgt_deallocate = */		FALSE,
-+		/* msgt_unused = */		0
-+	};
-+
-+#define	InP	(in)
-+#define	OutP	((mig_reply_header_t *) out)
-+      OutP->Head.msgh_bits =
-+	MACH_MSGH_BITS(MACH_MSGH_BITS_REMOTE(InP->msgh_bits), 0);
-+      OutP->Head.msgh_size = sizeof *OutP;
-+      OutP->Head.msgh_remote_port = InP->msgh_remote_port;
-+      OutP->Head.msgh_local_port = MACH_PORT_NULL;
-+      OutP->Head.msgh_seqno = 0;
-+      OutP->Head.msgh_id = InP->msgh_id + 100;
-+      OutP->RetCodeType = RetCodeType;
-+      OutP->RetCode = MIG_BAD_ID;
-+#undef InP
-+#undef OutP
-+}
-diff --git a/config.make.in b/config.make.in
-index 0f1390a..012bcd5 100644
---- a/config.make.in
-+++ b/config.make.in
-@@ -95,6 +95,10 @@ HAVE_BLKID = @HAVE_BLKID@
- libblkid_CFLAGS = @libblkid_CFLAGS@
- libblkid_LIBS = @libblkid_LIBS@
- 
-+# How to compile and link against libreadline.
-+HAVE_READLINE = @HAVE_READLINE@
-+libreadline_LIBS = @libreadline_LIBS@
-+
- # Whether Sun RPC support is available.
- HAVE_SUN_RPC = @HAVE_SUN_RPC@
- 
-diff --git a/configure.ac b/configure.ac
-index a388e09..d08e11d 100644
---- a/configure.ac
-+++ b/configure.ac
-@@ -333,6 +333,21 @@ PKG_CHECK_MODULES([libblkid], [blkid],
- AC_SUBST([libblkid_LIBS])
- AC_SUBST([libblkid_CFLAGS])
- 
-+AC_ARG_WITH([readline],
-+  [AS_HELP_STRING([--without-readline], [disable support for readline])],
-+  [],
-+  [with_readline=yes])
-+
-+LIBREADLINE=
-+AS_IF([test "x$with_readline" != xno],
-+  [AC_CHECK_LIB([readline], [main],
-+    [AC_SUBST([libreadline_LIBS], ["-lreadline -lhistory -lncurses"])
-+     AC_DEFINE([HAVE_LIBREADLINE], [1], [Define if you have libreadline])
-+    ],
-+    [AC_MSG_FAILURE(
-+       [readline test failed (--without-readline to disable)])],
-+    [-lncurses])])
-+
- AC_CONFIG_FILES([config.make ${makefiles}])
- AC_OUTPUT
- 
--- 
-2.1.4
-
diff --git a/debian/patches/0005-bootshell-improve-error-message.patch b/debian/patches/0005-bootshell-improve-error-message.patch
deleted file mode 100644
index 228bc055..00000000
--- a/debian/patches/0005-bootshell-improve-error-message.patch
+++ /dev/null
@@ -1,27 +0,0 @@
-From 6b469e6de715ca31ce9ec245a4e68daff8326c6e Mon Sep 17 00:00:00 2001
-From: Justus Winter <4winter@informatik.uni-hamburg.de>
-Date: Tue, 13 Jan 2015 17:16:46 +0100
-Subject: [PATCH hurd 5/5] bootshell: improve error message
-
-* bootshell/scheme.c (opexe_0): Mention the expression in the error
-message.
----
- bootshell/scheme.c | 2 +-
- 1 file changed, 1 insertion(+), 1 deletion(-)
-
-diff --git a/bootshell/scheme.c b/bootshell/scheme.c
-index 5ca5641..6f583f5 100644
---- a/bootshell/scheme.c
-+++ b/bootshell/scheme.c
-@@ -2679,7 +2679,7 @@ static pointer opexe_0(scheme *sc, enum scheme_opcodes op) {
-                sc->dump = cont_dump(sc->code);
-                s_return(sc,sc->args != sc->NIL ? car(sc->args) : sc->NIL);
-           } else {
--               Error_0(sc,"illegal function");
-+               Error_1(sc,"illegal function:", sc->code);
-           }
- 
-      case OP_DOMACRO:    /* do macro */
--- 
-2.1.4
-
diff --git a/debian/patches/series b/debian/patches/series
index d7cf67bc..f9b56961 100644
--- a/debian/patches/series
+++ b/debian/patches/series
@@ -48,8 +48,3 @@ proc-task-notify-0005-proc-fix-build.patch
 merge-me-0001-libports-avoid-acquiring-global-lock-in-message-disp.patch
 merge-me-0002-startup-faster-reboots.patch
 thomas_term.patch
-0001-libshouldbeinlibc-provide-mach_print-XXX.patch
-0002-libdiskfs-fixes-XXX.patch
-0003-trans-add-startup-standalone-XXX.patch
-0004-XXX-bootshell.patch
-0005-bootshell-improve-error-message.patch