add patch series

12 files changed, 11410 insertions, 0 deletions

diff --git a/debian/patches/0001-libports-silence-pointless-error-message.patch b/debian/patches/0001-libports-silence-pointless-error-message.patch
new file mode 100644
index 00000000..8e0fa7c8
--- /dev/null
+++ b/debian/patches/0001-libports-silence-pointless-error-message.patch
@@ -0,0 +1,30 @@
+From ba9d293d8fe40f6e634cf800c42ece97727ccd0f Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Sat, 3 Jan 2015 16:21:24 +0100
+Subject: [PATCH hurd 01/11] libports: silence pointless error message
+
+* libports/manage-multithread.c (adjust_priority): Silence pointless
+error message.
+---
+ libports/manage-multithread.c | 5 +++++
+ 1 file changed, 5 insertions(+)
+
+diff --git a/libports/manage-multithread.c b/libports/manage-multithread.c
+index 2067cba..ad22991 100644
+--- a/libports/manage-multithread.c
++++ b/libports/manage-multithread.c
+@@ -50,6 +50,11 @@ adjust_priority (unsigned int totalthreads)
+   thread_switch (MACH_PORT_NULL, SWITCH_OPTION_DEPRESS, t);
+ 
+   err = get_privileged_ports (&host_priv, NULL);
++  if (err == MACH_SEND_INVALID_DEST)
++    /* This is returned if we neither have the privileged host control
++       port cached nor have a proc server to talk to.  Give up.  */
++    return;
++
+   if (err)
+     goto error_host_priv;
+ 
+-- 
+2.1.4
+
diff --git a/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch b/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch
new file mode 100644
index 00000000..6fa71755
--- /dev/null
+++ b/debian/patches/0002-startup-give-the-tasks-we-create-a-name.patch
@@ -0,0 +1,33 @@
+From 522370cfcd2dde29dac73e1479d64a6af614cc25 Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Fri, 9 Jan 2015 11:06:52 +0100
+Subject: [PATCH hurd 02/11] startup: give the tasks we create a name
+
+* startup/startup.c (run): Name the tasks we start.
+---
+ startup/startup.c | 2 ++
+ 1 file changed, 2 insertions(+)
+
+diff --git a/startup/startup.c b/startup/startup.c
+index 601c894..c9fe215 100644
+--- a/startup/startup.c
++++ b/startup/startup.c
+@@ -33,6 +33,7 @@
+ #include <sys/file.h>
+ #include <unistd.h>
+ #include <string.h>
++#include <mach/gnumach.h>
+ #include <mach/notify.h>
+ #include <stdlib.h>
+ #include <hurd/msg.h>
+@@ -376,6 +377,7 @@ run (const char *server, mach_port_t *ports, task_t *task)
+ 	      printf ("Pausing for %s\n", prog);
+ 	      getchar ();
+ 	    }
++          task_set_name (*task, (char *) prog);
+ 	  err = file_exec (file, *task, 0,
+ 			   (char *)prog, strlen (prog) + 1, /* Args.  */
+ 			   startup_envz, startup_envz_len,
+-- 
+2.1.4
+
diff --git a/debian/patches/0003-auth-simplify-expression.patch b/debian/patches/0003-auth-simplify-expression.patch
new file mode 100644
index 00000000..91ce3272
--- /dev/null
+++ b/debian/patches/0003-auth-simplify-expression.patch
@@ -0,0 +1,35 @@
+From f37373b80de3bf74ca8792d5d64498366b088fab Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Fri, 2 Jan 2015 21:53:08 +0100
+Subject: [PATCH hurd 03/11] auth: simplify expression
+
+* auth/auth.c (S_auth_{user,server}_authenticate): Simplify expression.
+---
+ auth/auth.c | 4 ++--
+ 1 file changed, 2 insertions(+), 2 deletions(-)
+
+diff --git a/auth/auth.c b/auth/auth.c
+index c36bcb2..a7a188a 100644
+--- a/auth/auth.c
++++ b/auth/auth.c
+@@ -299,7 +299,7 @@ S_auth_user_authenticate (struct authhandle *userauth,
+   if (! userauth)
+     return EOPNOTSUPP;
+ 
+-  if (rendezvous == MACH_PORT_NULL || rendezvous == MACH_PORT_DEAD)
++  if (! MACH_PORT_VALID (rendezvous))
+     return EINVAL;
+ 
+   u.user = userauth;
+@@ -380,7 +380,7 @@ S_auth_server_authenticate (struct authhandle *serverauth,
+   if (! serverauth)
+     return EOPNOTSUPP;
+ 
+-  if (rendezvous == MACH_PORT_NULL || rendezvous == MACH_PORT_DEAD)
++  if (! MACH_PORT_VALID (rendezvous))
+     return EINVAL;
+ 
+   pthread_mutex_lock (&pending_lock);
+-- 
+2.1.4
+
diff --git a/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch b/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch
new file mode 100644
index 00000000..02c2c804
--- /dev/null
+++ b/debian/patches/0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch
@@ -0,0 +1,61 @@
+From 267fb2b2fcffe5ed09c18ee879193ad698223d65 Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Wed, 7 Jan 2015 16:00:06 +0100
+Subject: [PATCH hurd 04/11] auth: remove implicit assumption about the
+ bootstrap process
+
+The current code assumes that it can speak the startup protocol over
+its bootstrap port.
+
+* auth/auth.c (main): Generalize by trying to use `/servers/startup'
+before falling back to the bootstrap port.
+---
+ auth/auth.c | 15 ++++++++++++++-
+ 1 file changed, 14 insertions(+), 1 deletion(-)
+
+diff --git a/auth/auth.c b/auth/auth.c
+index a7a188a..d5ef587 100644
+--- a/auth/auth.c
++++ b/auth/auth.c
+@@ -25,6 +25,7 @@
+ #include <pthread.h>
+ #include <hurd.h>
+ #include <hurd/startup.h>
++#include <hurd/paths.h>
+ #include <hurd/ports.h>
+ #include <hurd/ihash.h>
+ #include <idvec.h>
+@@ -482,6 +483,7 @@ main (int argc, char **argv)
+ {
+   error_t err;
+   mach_port_t boot;
++  mach_port_t startup;
+   process_t proc;
+   mach_port_t hostpriv, masterdev;
+   struct authhandle *firstauth;
+@@ -518,10 +520,21 @@ main (int argc, char **argv)
+   _hurd_port_set (&_hurd_ports[INIT_PORT_PROC], proc);
+   _hurd_proc_init (argv, NULL, 0);
+ 
++  startup = file_name_lookup (_SERVERS_STARTUP, 0, 0);
++  if (! MACH_PORT_VALID (startup))
++    {
++      error (0, errno, "%s", _SERVERS_STARTUP);
++      /* Fall back to using the bootstrap port as before.  */
++      startup = boot;
++    }
++
+   /* Init knows intimately that we will be ready for messages
+      as soon as this returns. */
+-  startup_essential_task (boot, mach_task_self (), MACH_PORT_NULL, "auth",
++  startup_essential_task (startup, mach_task_self (), MACH_PORT_NULL, "auth",
+ 			  hostpriv);
++
++  if (startup != boot)
++    mach_port_deallocate (mach_task_self (), startup);
+   mach_port_deallocate (mach_task_self (), boot);
+   mach_port_deallocate (mach_task_self (), hostpriv);
+ 
+-- 
+2.1.4
+
diff --git a/debian/patches/0005-proc-call-startup_essential_task-earlier.patch b/debian/patches/0005-proc-call-startup_essential_task-earlier.patch
new file mode 100644
index 00000000..cd7f469d
--- /dev/null
+++ b/debian/patches/0005-proc-call-startup_essential_task-earlier.patch
@@ -0,0 +1,183 @@
+From 04f4b23c72c04136b2003dd121009de754fc7fa8 Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Wed, 7 Jan 2015 16:05:48 +0100
+Subject: [PATCH hurd 05/11] proc: call `startup_essential_task' earlier
+
+Previously, the proc server did not call `startup_essential_task'
+until it got the message port of the startup server using
+`proc_setmsgport'.
+
+Now that we have `/servers/startup', we can do this in main, before we
+start our message service loop.
+
+A complication arises because the traditional startup server is
+single-threaded.  Handle this by tweaking startup not to bind itself
+to `/servers/startup' before it is ready.
+
+* proc/main.c (main): Try to lookup `/servers/startup' and send the
+message here, or...
+* proc/msg.c (S_proc_setmsgport): ... fall back to the old way here.
+* proc/proc.h (startup_fallback): New variable.
+* startup/startup.c (main): Move code installing ourself on `/servers/startup'
+(install_as_translator): ... here.
+(launch_core_servers): And use it here, just before we reply to `/hurd/auth'.
+---
+ proc/main.c       | 23 +++++++++++++++++++++++
+ proc/msg.c        |  2 +-
+ proc/proc.h       |  2 ++
+ startup/startup.c | 44 ++++++++++++++++++++++++++++++++------------
+ 4 files changed, 58 insertions(+), 13 deletions(-)
+
+diff --git a/proc/main.c b/proc/main.c
+index b4288fb..6df4141 100644
+--- a/proc/main.c
++++ b/proc/main.c
+@@ -22,6 +22,7 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
+ #include <mach.h>
+ #include <hurd/hurd_types.h>
+ #include <hurd.h>
++#include <hurd/paths.h>
+ #include <hurd/startup.h>
+ #include <device/device.h>
+ #include <assert.h>
+@@ -62,6 +63,7 @@ message_demuxer (mach_msg_header_t *inp,
+ }
+ 
+ pthread_mutex_t global_lock = PTHREAD_MUTEX_INITIALIZER;
++int startup_fallback;
+ 
+ error_t
+ increase_priority (void)
+@@ -99,6 +101,7 @@ main (int argc, char **argv, char **envp)
+   error_t err;
+   void *genport;
+   process_t startup_port;
++  mach_port_t startup;
+   struct argp argp = { 0, 0, 0, "Hurd process server" };
+ 
+   argp_parse (&argp, argc, argv, 0, 0, 0);
+@@ -173,6 +176,26 @@ main (int argc, char **argv, char **envp)
+     mach_port_deallocate (mach_task_self (), cons);
+   }
+ 
++  startup = file_name_lookup (_SERVERS_STARTUP, 0, 0);
++  if (MACH_PORT_VALID (startup))
++    {
++      err = startup_essential_task (startup, mach_task_self (),
++				    MACH_PORT_NULL, "proc", _hurd_host_priv);
++      if (err)
++	/* Due to the single-threaded nature of /hurd/startup, it can
++	   only handle requests once the core server bootstrap has
++	   completed.  Therefore, it does not bind itself to
++	   /servers/startup until it is ready.	*/
++	/* Fall back to abusing the message port lookup.  */
++	startup_fallback = 1;
++
++      err = mach_port_deallocate (mach_task_self (), startup);
++      assert_perror (err);
++    }
++  else
++    /* Fall back to abusing the message port lookup.	*/
++    startup_fallback = 1;
++
+   while (1)
+     ports_manage_port_operations_multithread (proc_bucket,
+ 					      message_demuxer,
+diff --git a/proc/msg.c b/proc/msg.c
+index 796cae3..c7bab99 100644
+--- a/proc/msg.c
++++ b/proc/msg.c
+@@ -63,7 +63,7 @@ S_proc_setmsgport (struct proc *p,
+     prociterate (check_message_return, p);
+   p->p_checkmsghangs = 0;
+ 
+-  if (p == startup_proc)
++  if (p == startup_proc && startup_fallback)
+     {
+     /* Init is single threaded, so we can't delay our reply for
+        the essential task RPC; spawn a thread to do it. */
+diff --git a/proc/proc.h b/proc/proc.h
+index a056d18..4be1de4 100644
+--- a/proc/proc.h
++++ b/proc/proc.h
+@@ -151,6 +151,8 @@ mach_port_t generic_port;	/* messages not related to a specific proc */
+ 
+ pthread_mutex_t global_lock;
+ 
++extern int startup_fallback;	/* (ab)use /hurd/startup's message port */
++
+ /* Forward declarations */
+ void complete_wait (struct proc *, int);
+ int check_uid (struct proc *, uid_t);
+diff --git a/startup/startup.c b/startup/startup.c
+index c9fe215..e01d2a8 100644
+--- a/startup/startup.c
++++ b/startup/startup.c
+@@ -514,6 +514,32 @@ demuxer (mach_msg_header_t *inp,
+ 	  startup_server (inp, outp));
+ }
+ 
++error_t
++install_as_translator (void)
++{
++  error_t err;
++  file_t node;
++
++  node = file_name_lookup (_SERVERS_STARTUP, O_NOTRANS, 0);
++  if (! MACH_PORT_VALID (node))
++    {
++      if (errno == ENOENT)
++	{
++	  /* Degrade gracefully if the node does not exist.  */
++	  error (0, errno, "%s", _SERVERS_STARTUP);
++	  return 0;
++	}
++      return errno;
++    }
++
++  err = file_set_translator (node,
++			     0, FS_TRANS_SET, 0,
++			     NULL, 0,
++			     startup, MACH_MSG_TYPE_COPY_SEND);
++  mach_port_deallocate (mach_task_self (), node);
++  return err;
++}
++
+ static int
+ parse_opt (int key, char *arg, struct argp_state *state)
+ {
+@@ -587,18 +613,6 @@ main (int argc, char **argv, char **envp)
+   /* Crash if the boot filesystem task dies.  */
+   request_dead_name (fstask);
+ 
+-  file_t node = file_name_lookup (_SERVERS_STARTUP, O_NOTRANS, 0);
+-  if (node == MACH_PORT_NULL)
+-    error (0, errno, "%s", _SERVERS_STARTUP);
+-  else
+-    {
+-      file_set_translator (node,
+-			   0, FS_TRANS_SET, 0,
+-			   NULL, 0,
+-			   startup, MACH_MSG_TYPE_COPY_SEND);
+-      mach_port_deallocate (mach_task_self (), node);
+-    }
+-
+   /* Set up the set of ports we will pass to the programs we exec.  */
+   for (i = 0; i < INIT_PORT_MAX; i++)
+     switch (i)
+@@ -672,6 +686,12 @@ launch_core_servers (void)
+   proc_task2proc (procserver, authtask, &authproc);
+   proc_mark_important (authproc);
+   proc_mark_exec (authproc);
++
++  err = install_as_translator ();
++  if (err)
++    /* Good luck.  Who knows, maybe it's an old installation.  */
++    error (0, err, "Failed to bind to " _SERVERS_STARTUP);
++
+   startup_authinit_reply (authreply, authreplytype, 0, authproc,
+ 			  MACH_MSG_TYPE_COPY_SEND);
+   mach_port_deallocate (mach_task_self (), authproc);
+-- 
+2.1.4
+
diff --git a/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch b/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch
new file mode 100644
index 00000000..fdf3969a
--- /dev/null
+++ b/debian/patches/0006-libshouldbeinlibc-provide-mach_print-XXX.patch
@@ -0,0 +1,80 @@
+From 383f73297a9b1658c4c1fb2112a1d47e3e8e3c14 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 06/11] 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 | 30 ++++++++++++++++++++++++++++++
+ libshouldbeinlibc/mach-print.h |  2 ++
+ 3 files changed, 34 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..2b31dca
+--- /dev/null
++++ b/libshouldbeinlibc/mach-print.c
+@@ -0,0 +1,30 @@
++#include <stdio.h>
++#include <stdarg.h>
++
++#define BUFFER_SIZE 1024
++
++void
++mach_print(const char *msg)
++{
++  // XXX check architecture
++  asm (" pop %%eax;"
++       " push %0;"
++       " push %%eax;"
++       " mov $0xffffffe2, %%eax;"
++       " lcall $0x7, $0x0;"
++       : /* No outputs.  */
++       : "r" (msg)
++       : "eax");
++}
++
++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/0007-libdiskfs-fixes-XXX.patch b/debian/patches/0007-libdiskfs-fixes-XXX.patch
new file mode 100644
index 00000000..5b377a56
--- /dev/null
+++ b/debian/patches/0007-libdiskfs-fixes-XXX.patch
@@ -0,0 +1,66 @@
+From cdda9ead492454f3810f5473b7eefd8eab6e29ad 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 07/11] 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 cfe2303..5233cae 100644
+--- a/libdiskfs/boot-start.c
++++ b/libdiskfs/boot-start.c
+@@ -464,7 +464,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/0008-trans-add-startup-standalone-XXX.patch b/debian/patches/0008-trans-add-startup-standalone-XXX.patch
new file mode 100644
index 00000000..b4259768
--- /dev/null
+++ b/debian/patches/0008-trans-add-startup-standalone-XXX.patch
@@ -0,0 +1,486 @@
+From 6686c9fef8c7298e4bf33bb75705ca690add7b37 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 08/11] 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 | 428 +++++++++++++++++++++++++++++++++++++++++++++
+ 2 files changed, 433 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..dcb2cb4
+--- /dev/null
++++ b/trans/startup-standalone.c
+@@ -0,0 +1,428 @@
++/* 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[] =
++{
++  {0}
++};
++
++static error_t
++parse_opt (int opt, char *arg, struct argp_state *state)
++{
++  switch (opt)
++    {
++    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)
++{
++  return 0;
++}
++
++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;
++
++  // XXX
++  fprintf (stdout, "stdout\n");
++  fflush (stdout);
++  fprintf (stderr, "stderr\n");
++
++  /* 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)
++{
++  struct ntfy_task *nt;
++  request_dead_name (notify);
++
++  /* 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.  */
++	mach_port_deallocate (mach_task_self (), dead_name);
++	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/0009-XXX-bootshell.patch b/debian/patches/0009-XXX-bootshell.patch
new file mode 100644
index 00000000..8864809c
--- /dev/null
+++ b/debian/patches/0009-XXX-bootshell.patch
@@ -0,0 +1,10323 @@
+From e41e16d77b66887d6630e3b4a05ae8a57bfe340d 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 09/11] XXX bootshell
+
+XXX hack in toplevel Makefile.
+---
+ Makefile                        |    1 +
+ bootshell/COPYING.tinyscheme    |   31 +
+ bootshell/Makefile              |   63 +
+ bootshell/Manual.txt            |  452 ++++
+ bootshell/MiniSCHEMETribute.txt |   88 +
+ bootshell/boot.scm              |  249 ++
+ bootshell/bootshell.h           |   32 +
+ bootshell/exceptions.c          |   72 +
+ bootshell/exec-startup.c        |  162 ++
+ bootshell/ffi.c                 |  819 +++++++
+ bootshell/ffi.h                 |  130 +
+ bootshell/fs.c                  |   91 +
+ bootshell/fsys.c                |   74 +
+ bootshell/hack.txt              |  244 ++
+ bootshell/init.scm              |  716 ++++++
+ bootshell/main.c                |  296 +++
+ bootshell/mig-decls.h           |    3 +
+ bootshell/mig-mutate.h          |   27 +
+ bootshell/opdefines.h           |  195 ++
+ bootshell/runsystem.scm         |  175 ++
+ bootshell/scheme-config.h       |   11 +
+ bootshell/scheme-private.h      |  210 ++
+ bootshell/scheme.c              | 5075 +++++++++++++++++++++++++++++++++++++++
+ bootshell/scheme.h              |  255 ++
+ bootshell/startup.c             |  487 ++++
+ bootshell/startup.h             |   12 +
+ bootshell/utils.c               |  121 +
+ 27 files changed, 10091 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..97e30f7
+--- /dev/null
++++ b/bootshell/Makefile
+@@ -0,0 +1,63 @@
++# 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 \
++
++SPROTOCOLS := exc exec_startup fs fsys startup
++UPROTOCOLS := startup startup_reply
++
++MIGSTUBS:= \
++	$(foreach p,$(SPROTOCOLS),$(p)Server.o) \
++	$(foreach p,$(UPROTOCOLS),$(p)User.o)
++OBJS 	:= $(SRCS:.c=.o) $(SCRIPTS:.scm=.o) $(MIGSTUBS)
++
++HURDLIBS:= shouldbeinlibc
++#OTHERLIBS:= -lpthread -lreadline -lhistory \
++#	$(shell pkg-config --libs --static ncurses)
++OTHERLIBS:= -lpthread
++CFLAGS += -imacros scheme-config.h
++LDFLAGS += -static
++MIGSFLAGS := -imacros mig-mutate.h
++
++%.o: %.scm
++	$(LD) -r --format=binary $< -o $@
++
++NOWARN := conversion sign-conversion switch unused-function
++CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS))
++
++CFLAGS += -Wno-sign-conversion
++CFLAGS += -O0 -fno-omit-frame-pointer
++
++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..f6b4d25
+--- /dev/null
++++ b/bootshell/boot.scm
+@@ -0,0 +1,249 @@
++;; 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.  XXX: Crappy workaround.
++(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 interface.
++
++(define (ffi-apply name f args)
++  (let ((result (apply f args)))
++    (cond
++     ((null? result) (throw "Got NULL."))
++     ((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)
++  (let ((prefix ""))
++    (do () (#f)
++      (let ((line (prompt (p prefix))))
++	(set! prefix (string-append prefix line))
++
++	(if (> (string-length prefix) 0)
++	    (let ((c (read (open-input-string prefix))))
++	      (cond
++	       ((eof-object? c) ())
++	       (else (catch (echo "Error: " last-exception)
++			    (echo "  ===> " (eval c)))
++		     (set! prefix "")))))))))
++
++; unfortunately, this doesn't work
++;(define (shell p)
++;  (display (p))
++;  (eval (read))
++;  (shell p))
++
++(define version "bootshell/TinySCHEME 1.41")
++
++(define (prompt-append-prefix prompt prefix)
++  (string-append prompt (if (> (string-length prefix) 0)
++			    (string-append prefix " ... ")
++			    "> ")))
++
++(define (interactive-repl)
++  (shell (lambda (p) (prompt-append-prefix "(bootshell) " p))))
++
++(define (emergency-shell)
++  (shell (lambda (p) (prompt-append-prefix "(emergency-shell) " p))))
++
++(define (panic . msg)
++  (display "\n\npanic: ")
++  (map display msg)
++  (newline)
++  (emergency-shell))
++
++;; 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..2112f83
+--- /dev/null
++++ b/bootshell/bootshell.h
+@@ -0,0 +1,32 @@
++#ifndef _HURD_BOOTSHELL_H
++#define _HURD_BOOTSHELL_H
++
++#include <mach.h>
++
++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,
++			      mach_msg_id_t *msgh_id);
++
++#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..b036a4b
+--- /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 <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;
++  mach_port_t rootport;
++
++  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 (), 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;
++  mach_msg_id_t msgh_id;
++
++  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, &msgh_id);
++  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..8cee903
+--- /dev/null
++++ b/bootshell/ffi.c
+@@ -0,0 +1,819 @@
++#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>
++
++#include "bootshell.h"
++#include "ffi.h"
++
++#include "startup.h"
++
++#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);
++}
++
++char *rl_gets (const char *prompt);
++
++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);
++  SC_RETURN_STRING (sc, line);
++}
++
++pointer
++do_trace (scheme *sc, pointer args)
++{
++  sc->tracing = args != sc->NIL && ! is_false (pair_car (args));
++  return sc->NIL;
++}
++
++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);
++  // dealloc ?
++  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 and proc server ports.  */
++  _hurd_port_set (&_hurd_ports[INIT_PORT_AUTH], authserver);
++  portarray_template[INIT_PORT_AUTH] = authserver;
++  // dealloc ?
++  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_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);
++}
++
++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);
++      if (err)
++	SC_RETURN (sc);
++    }
++
++  dtable[STDIN_FILENO] = getdport (STDIN_FILENO);
++  dtable[STDOUT_FILENO] = getdport (STDOUT_FILENO);
++  dtable[STDERR_FILENO] = getdport (STDERR_FILENO);
++
++  memcpy (portarray, portarray_template, INIT_PORT_MAX * sizeof *portarray);
++  portarray[INIT_PORT_CWDIR] = getcwdir ();
++  portarray[INIT_PORT_CRDIR] = getcrdir ();
++  portarray[INIT_PORT_PROC] = child_proc;
++  portarray[INIT_PORT_BOOTSTRAP] = 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);
++  SC_RETURN_INT (sc, task);
++
++ 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 (sc);
++}
++
++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)
++{
++  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_ffi_function (sc, "mach-port-allocate", _mach_port_allocate);
++  define_ffi_function (sc, "mach-port-deallocate", _mach_port_deallocate);
++  define_ffi_function (sc, "mach-port-destroy", _mach_port_destroy);
++  //define_function (sc, mach_port_get_refs);
++  //define_function (sc, mach_port_mod_refs);
++  define_ffi_function (sc, "mach-port-insert-right", _mach_port_insert_right);
++  //define_function (sc, mach_port_extract_right);
++
++  define_function (sc, mach_print);
++  define_ffi_function (sc, "task-create", _task_create);
++  define_ffi_function (sc, "task-resume", _task_resume);
++  define_ffi_function (sc, "task-terminate", _task_terminate);
++  define_ffi_function (sc, "task-get-special-port", _task_get_special_port);
++  define_ffi_function (sc, "task-set-special-port", _task_set_special_port);
++  define_ffi_function (sc, "host-reboot", _host_reboot);
++
++  /* Device protocol.  */
++  define_constant (sc, D_READ);
++  define_constant (sc, D_WRITE);
++  define_ffi_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);
++
++  define_function (sc, trace);
++  define_ffi_function (sc, "prompt", _prompt);
++
++  /* glibc.  */
++  define_function (sc, sleep);
++  define_function (sc, usleep);
++  define_ffi_function (sc, "getcwd", _getcwd);
++  define_ffi_function (sc, "chdir", _chdir);
++  define_ffi_function (sc, "strerror", _strerror);
++  define_ffi_function (sc, "getproc", _getproc);
++
++  /* Boot process */
++  define_ffi_function (sc, "bind-root", _bind_root);
++  define_ffi_function (sc, "bind-proc", _bind_proc);
++  define_ffi_function (sc, "bind-auth", _bind_auth);
++  define_ffi_function (sc, "fsys-init", _fsys_init);
++
++  /* Early bootstrap protocols.	 */
++  define_ffi_function (sc, "handle-startup-procinit", _handle_startup_procinit);
++  define_ffi_function (sc, "handle-startup-authinit", _handle_startup_authinit);
++  define_ffi_function (sc, "startup-procinit-reply", _startup_procinit_reply);
++  define_ffi_function (sc, "startup-authinit-reply", _startup_authinit_reply);
++
++  define_ffi_function (sc, "startup-essential-task", _startup_essential_task);
++  define_ffi_function (sc, "startup-request-notification",
++		       _startup_request_notification);
++  define_ffi_function (sc, "startup-reboot", _startup_reboot);
++
++  /* Process and translator startup.  */
++  define_ffi_function (sc, "handle-exec-startup",  _handle_exec_startup);
++  define_ffi_function (sc, "handle-fsys-startup", _handle_fsys_startup);
++
++  /* Hurd fs API */
++  define_ffi_function (sc, "file-name-lookup", _file_name_lookup);
++  define_ffi_function (sc, "file-set-translator", _file_set_translator);
++  define_ffi_function (sc, "file-get-fs-options", _file_get_fs_options);
++
++  /* Hurd process API */
++  define_ffi_function (sc, "proc->task->proc", _proc_task2proc);
++  define_ffi_function (sc, "proc->mark-important!", _proc_mark_important);
++  define_ffi_function (sc, "proc->mark-exec!", _proc_mark_exec);
++  define_ffi_function (sc, "proc->task->child!", _proc_child);
++  define_ffi_function (sc, "proc->task->set-init-task!", _proc_set_init_task);
++
++  /* Hurd hacks.  */
++  define_ffi_function (sc, "_exec", __exec);
++  define_ffi_function (sc, "start-handling-early-startup",
++		       _start_handling_early_startup);
++  define_ffi_function (sc, "get-essential-tasks", _get_essential_tasks);
++  define_ffi_function (sc, "get-registered-tasks", _get_registered_tasks);
++  ffi_update (sc);
++}
+diff --git a/bootshell/ffi.h b/bootshell/ffi.h
+new file mode 100644
+index 0000000..b1b3f97
+--- /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)))
++
++#define define_function(S, F)						\
++  scheme_define ((S),							\
++		 (S)->global_env,					\
++		 mk_symbol ((S), schemify_name (#F, 0)),		\
++		 mk_foreign_func ((S), (do_##F)))
++
++#define define_ffi_function(S, P, F)				\
++  ({								\
++  char _sc_buf[256];						\
++  define_function (S, 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##_start[]	asm("_binary_"#X"_start");  \
++  extern char X##_end[]		asm("_binary_"#X"_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_scm);
++declare_embedded_script (boot_scm);
++declare_embedded_script (runsystem_scm);
++
++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..3c5afa2
+--- /dev/null
++++ b/bootshell/fsys.c
+@@ -0,0 +1,74 @@
++#include <assert.h>
++#include <hurd.h>
++#include <mach.h>
++#include <mach/message.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;
++}
++
++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;
++  extern boolean_t fsys_server ();
++  mach_msg_id_t msgh_id;
++
++  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_server, 0, bootstrap,
++				      MACH_RCV_TIMEOUT|MACH_SEND_TIMEOUT,
++				      timeout, &msgh_id);
++  if (err != MACH_MSG_SUCCESS)
++    return err;
++
++  if (msgh_id != 22000)
++    {
++      fprintf (stderr, " (XXy:%d)", msgh_id); //XXX
++      return EINVAL;
++    }
++
++  *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..f5f3ab5
+--- /dev/null
++++ b/bootshell/main.c
+@@ -0,0 +1,296 @@
++/* 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>
++
++#if LIBREADLINE_LINKS
++#include <readline/readline.h>
++#include <readline/history.h>
++#endif
++
++#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);
++}
++
++void ffi_update (scheme *sc); //XXX
++
++
++/* A static variable for holding the line. */
++static char *line_read = (char *)NULL;
++
++/* Read a string, and return a pointer to it.
++   Returns NULL on EOF. */
++char *
++rl_gets (const char *prompt)
++{
++  /* If the buffer has already been allocated,
++     return the memory to the free pool. */
++  if (line_read)
++    {
++      free (line_read);
++      line_read = (char *)NULL;
++    }
++
++#if 0
++  /* Get a line from the user. */
++  line_read = readline (prompt);
++
++  /* If the line has any text in it,
++     save it on the history. */
++  if (line_read && *line_read)
++    add_history (line_read);
++#else
++  printf ("%s", prompt);
++  fflush (stdout);
++  line_read = malloc (80);
++  if (line_read != NULL)
++    fgets (line_read, 80, stdin);
++#endif
++
++  /* rstrip line  */
++  if (line_read && strlen (line_read) > 0)
++    for (char *p = &line_read[strlen (line_read) - 1]; isspace (*p); p--)
++      *p = 0;
++
++  return line_read;
++}
++
++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_scm);
++  load_embedded_script (&scm, boot_scm);
++  load_embedded_script (&scm, runsystem_scm);
++
++  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..940b862
+--- /dev/null
++++ b/bootshell/runsystem.scm
+@@ -0,0 +1,175 @@
++;; 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)))
++
++;; Perform a traditional Hurd server bootstrap.  Expects suspended
++;; rootfs and exec servers, with command line arguments prepared by
++;; the kernel.
++(define (bootstrap)
++  (log "Hurd server bootstrap: ")
++
++  (log "rootfs ")
++  (let ((rootfs-control (bind-root (resume-translator rootfs-server-task
++						      '())))
++	(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 '()))
++
++    (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))
++      (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))
++      (mach-port-deallocate mach-task-self (:server pc))
++      (mach-port-deallocate mach-task-self (:server ac))))
++
++  ;; 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.
++  (let ((startup (file-name-lookup "/servers/startup" 0 0))
++	;; Projections.
++	(:port car) (:name cdr))
++    ;; 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))
++    (mach-port-deallocate mach-task-self startup))
++
++  (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..20ef332
+--- /dev/null
++++ b/bootshell/scheme-config.h
+@@ -0,0 +1,11 @@
++#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
+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..abb600c
+--- /dev/null
++++ b/bootshell/startup.c
+@@ -0,0 +1,487 @@
++#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 */
++  if (request->msgh_id == 29000		/* startup_essential_task */
++      || request->msgh_id == 29001)	/* startup_request_notification */
++    return startup_server (request, reply);
++  else if (request->msgh_id == 22001		/* fsys_goaway */
++	   || request->msgh_id == 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;
++  mach_msg_id_t msgh_id;
++
++  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, &msgh_id);
++  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;
++  mach_msg_id_t msgh_id;
++
++  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, &msgh_id);
++  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..69f760f
+--- /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..31c3f4a
+--- /dev/null
++++ b/bootshell/utils.c
+@@ -0,0 +1,121 @@
++#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,
++			      mach_msg_id_t *msgh_id)
++{
++  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;
++
++  *msgh_id = request->Head.msgh_id;
++
++  /* 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
++}
+-- 
+2.1.4
+
diff --git a/debian/patches/0010-potfu_bootshell_fixbuild.patch b/debian/patches/0010-potfu_bootshell_fixbuild.patch
new file mode 100644
index 00000000..7f475cad
--- /dev/null
+++ b/debian/patches/0010-potfu_bootshell_fixbuild.patch
@@ -0,0 +1,75 @@
+From 8905e266cc72b915cae5be6630907ba08789cd06 Mon Sep 17 00:00:00 2001
+From: Justus Winter <4winter@informatik.uni-hamburg.de>
+Date: Wed, 14 Jan 2015 02:13:46 +0100
+Subject: [PATCH hurd 10/11] potfu_bootshell_fixbuild
+
+---
+ bootshell/Makefile |  4 +++-
+ bootshell/ffi.h    | 11 ++++++-----
+ bootshell/main.c   |  6 +++---
+ 3 files changed, 12 insertions(+), 9 deletions(-)
+
+diff --git a/bootshell/Makefile b/bootshell/Makefile
+index 97e30f7..2b22696 100644
+--- a/bootshell/Makefile
++++ b/bootshell/Makefile
+@@ -52,7 +52,9 @@ LDFLAGS += -static
+ MIGSFLAGS := -imacros mig-mutate.h
+ 
+ %.o: %.scm
+-	$(LD) -r --format=binary $< -o $@
++	cat <$< >.$@
++	$(LD) -r --format=binary .$@ -o $@
++	rm .$@
+ 
+ NOWARN := conversion sign-conversion switch unused-function
+ CFLAGS := $(filter-out $(foreach flag,$NOWARN,-W$(flag)),$(CFLAGS))
+diff --git a/bootshell/ffi.h b/bootshell/ffi.h
+index b1b3f97..60ab50d 100644
+--- a/bootshell/ffi.h
++++ b/bootshell/ffi.h
+@@ -94,8 +94,9 @@
+ void scheme_load_mem (scheme *, const char *, const char *);
+ 
+ #define declare_embedded_script(X)			    \
+-  extern char X##_start[]	asm("_binary_"#X"_start");  \
+-  extern char X##_end[]		asm("_binary_"#X"_end")
++  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)					\
+   ({									\
+@@ -104,9 +105,9 @@ void scheme_load_mem (scheme *, const char *, const char *);
+       fprintf (stderr, "Errors encountered evaluating %s\n", #X);	\
+   })
+ 
+-declare_embedded_script (init_scm);
+-declare_embedded_script (boot_scm);
+-declare_embedded_script (runsystem_scm);
++declare_embedded_script (init);
++declare_embedded_script (boot);
++declare_embedded_script (runsystem);
+ 
+ void ffi_update (scheme *sc);
+ void ffi_init (scheme *sc);
+diff --git a/bootshell/main.c b/bootshell/main.c
+index f5f3ab5..823a143 100644
+--- a/bootshell/main.c
++++ b/bootshell/main.c
+@@ -232,9 +232,9 @@ main (int argc, char **argv)
+ 
+   ffi_init (&scm);
+ 
+-  load_embedded_script (&scm, init_scm);
+-  load_embedded_script (&scm, boot_scm);
+-  load_embedded_script (&scm, runsystem_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);
+-- 
+2.1.4
+
diff --git a/debian/patches/0011-bootshell-improve-error-message.patch b/debian/patches/0011-bootshell-improve-error-message.patch
new file mode 100644
index 00000000..6d4ae6e1
--- /dev/null
+++ b/debian/patches/0011-bootshell-improve-error-message.patch
@@ -0,0 +1,27 @@
+From 13246988637409ac6487ac4ac2909e14d7fbb812 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 11/11] 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 bde0ea07..7bf3ac1a 100644
--- a/debian/patches/series
+++ b/debian/patches/series
@@ -47,3 +47,14 @@ libports-payloads.patch
 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
+0001-libports-silence-pointless-error-message.patch
+0002-startup-give-the-tasks-we-create-a-name.patch
+0003-auth-simplify-expression.patch
+0004-auth-remove-implicit-assumption-about-the-bootstrap-.patch
+0005-proc-call-startup_essential_task-earlier.patch
+0006-libshouldbeinlibc-provide-mach_print-XXX.patch
+0007-libdiskfs-fixes-XXX.patch
+0008-trans-add-startup-standalone-XXX.patch
+0009-XXX-bootshell.patch
+0010-potfu_bootshell_fixbuild.patch
+0011-bootshell-improve-error-message.patch