Index: payloads/libpayload/include/libpayload.h
===================================================================
--- payloads/libpayload/include/libpayload.h	(revision 5088)
+++ payloads/libpayload/include/libpayload.h	(working copy)
@@ -52,6 +52,16 @@
 #include <lar.h>
 #include <pci.h>
 
+#ifndef _SIZE_T_DEFINED_
+#define _SIZE_T_DEFINED_
+typedef unsigned long size_t;
+#endif
+
+#ifndef _SSIZE_T_DEFINED_
+#define _SSIZE_T_DEFINED_
+typedef long ssize_t;
+#endif
+
 #define MIN(a,b) ((a) < (b) ? (a) : (b))
 #define MAX(a,b) ((a) > (b) ? (a) : (b))
 #define ARRAY_SIZE(a) (sizeof(a) / sizeof((a)[0]))
@@ -293,6 +303,43 @@
  * @defgroup printf Print functions
  * @{
  */
+
+struct _IO_FILE;
+typedef struct _IO_FILE FILE;
+
+#define stdin (&__stdin)
+#define stdout (&__stdout)
+#define stderr (&__stderr)
+
+extern FILE __stdin;
+extern FILE __stdout;
+extern FILE __stderr;
+
+#ifndef EOF
+#define EOF (-1)
+#endif
+
+
+#ifdef DEBUG
+#define DEBUG_PRINT(fmt, ...) \
+	do { if (DEBUG) printf("%s:%d:%s(): " fmt, __FILE__,		\
+						   __LINE__, __func__, ##__VA_ARGS__); } while (0)
+#else
+#define DEBUG_PRINT(fmt, ...)
+#endif
+
+
+int fileno (FILE *stream);
+FILE *fopen(const char *path, const char *mode);
+int fclose(FILE *fp);
+int fgetc(FILE *stream);
+int ungetc(int c, FILE *stream);
+int fputs(const char *s, FILE *stream);
+size_t fwrite(const void *ptr, size_t size, size_t nmemb,FILE *stream);
+/* size_t fread(void *ptr, size_t size, size_t nmemb, FILE *stream); */
+int fputc(int c, FILE *stream);
+int fprintf(FILE *stream, const char *format, ...);
+
 int snprintf(char *str, size_t size, const char *fmt, ...);
 int sprintf(char *str, const char *fmt, ...);
 int vsnprintf(char *str, size_t size, const char *fmt, va_list ap);
@@ -343,7 +390,14 @@
 char *strdup(const char *s);
 char *strstr(const char *h, const char *n);
 char *strsep(char **stringp, const char *delim);
-unsigned int strtoul(const char *s, char **nptr, int base);
+unsigned long int strtoul(const char *s, char **ptr, int base);
+unsigned long long int strtoull(const char *s, char **ptr, int base);
+long int strtol(const char *ptr, char **endptr, int base);
+long int atol(const char *ptr);
+double strtod(const char *ptr, char **endptr);
+double atof(const char *ptr);
+char* dtoa_dec(double d);
+char* dtoa_hexa(double d);
 
 /** @} */
 
Index: payloads/libpayload/include/curses.h
===================================================================
--- payloads/libpayload/include/curses.h	(revision 5088)
+++ payloads/libpayload/include/curses.h	(working copy)
@@ -149,10 +149,10 @@
 #endif
 
 //// #include <stdio.h>
-struct _IO_FILE {
-	// FIXME
-};
-typedef struct _IO_FILE FILE;
+// struct _IO_FILE {
+// 	// FIXME
+// };
+// typedef struct _IO_FILE FILE;
 //// #include <ncursesw/unctrl.h>
 #include <stdarg.h>	/* we need va_list */
 //// #define va_list int	// FIXME
Index: payloads/libpayload/libc/Makefile.inc
===================================================================
--- payloads/libpayload/libc/Makefile.inc	(revision 5088)
+++ payloads/libpayload/libc/Makefile.inc	(working copy)
@@ -28,7 +28,9 @@
 ## SUCH DAMAGE.
 ##
 
-TARGETS-$(CONFIG_LIBC) += libc/malloc.o libc/printf.o libc/console.o libc/string.o
+TARGETS-$(CONFIG_LIBC) += libc/malloc.o libc/console.o libc/string.o libc/printf.o
+TARGETS-$(CONFIG_LIBC) += libc/sys.o libc/stdio.o
 TARGETS-$(CONFIG_LIBC) += libc/memory.o libc/ctype.o libc/ipchecksum.o libc/lib.o
 TARGETS-$(CONFIG_LIBC) += libc/rand.o libc/time.o libc/lar.o libc/exec.o
 TARGETS-$(CONFIG_LIBC) += libc/readline.o libc/getopt_long.o libc/sysinfo.o
+
Index: payloads/libpayload/libc/string.c
===================================================================
--- payloads/libpayload/libc/string.c	(revision 5088)
+++ payloads/libpayload/libc/string.c	(working copy)
@@ -30,6 +30,7 @@
 
 #include <libpayload.h>
 
+
 /**
  * Calculate the length of a fixed-size string.
  *
@@ -181,6 +182,7 @@
 	return d;
 }
 
+
 /**
  * Find a character in a string.
  *
@@ -306,16 +308,16 @@
 }
 
 /**
- * Convert the initial portion of a string into an unsigned int
+ * Convert the initial portion of a string into an unsigned long int
  * @param ptr A pointer to the string to convert
  * @param endptr A pointer to the unconverted part of the string
  * @param base The base of the number to convert, or 0 for auto
- * @return An unsigned integer representation of the string
+ * @return An unsigned long integer representation of the string
  */
 
-unsigned int strtoul(const char *ptr, char **endptr, int base)
+unsigned long int strtoul(const char *ptr, char **endptr, int base)
 {
-        int ret = 0;
+	unsigned long int ret = 0;
 
 	if (endptr != NULL)
 		*endptr = (char *) ptr;
@@ -363,3 +365,103 @@
 }
 
 
+/**
+ * Convert the initial portion of a string into an unsigned long long int
+ * @param ptr A pointer to the string to convert
+ * @param endptr A pointer to the unconverted part of the string
+ * @param base The base of the number to convert, or 0 for auto
+ * @return An unsigned long long integer representation of the string
+ */
+
+unsigned long long int strtoull(const char *ptr, char **endptr, int base)
+{
+	unsigned long long int ret = 0;
+
+	if (endptr != NULL)
+		*endptr = (char *) ptr;
+
+        /* Purge whitespace */
+
+        for( ; *ptr && isspace(*ptr); ptr++);
+
+        if (!*ptr)
+                return 0;
+
+        /* Determine the base */
+
+        if (base == 0) {
+		if (ptr[0] == '0' && (ptr[1] == 'x' || ptr[1] == 'X'))
+			base = 16;
+		else if (ptr[0] == '0') {
+			base = 8;
+			ptr++;
+		}
+		else
+			base = 10;
+        }
+
+	/* Base 16 allows the 0x on front - so skip over it */
+
+	if (base == 16) {
+		if (ptr[0] == '0' && (ptr[1] == 'x' || ptr[1] == 'X'))
+			ptr += 2;
+	}
+
+	/* If the first character isn't valid, then don't
+         * bother */
+
+        if (!*ptr || !_valid(*ptr, base))
+                return 0;
+
+        for( ; *ptr && _valid(*ptr, base); ptr++)
+                ret = (ret * base) + _offset(*ptr, base);
+
+	if (endptr != NULL)
+		*endptr = (char *) ptr;
+
+        return ret;
+}
+
+
+/**
+ * Convert the initial portion of a string into a long int
+ * @param ptr A pointer to the string to convert
+ * @param endptr A pointer to the unconverted part of the string
+ * @param base The base of the number to convert, or 0 for auto
+ * @return A long integer representation of the string
+ */
+
+long int strtol(const char *ptr, char **endptr, int base)
+{
+	int sign=1;
+
+	/* Purge whitespace */	
+	for( ; *ptr && isspace(*ptr); ptr++);
+	
+	if (!*ptr)
+		return 0;
+
+	if(*ptr == '-')
+	{
+		sign=-1;
+		ptr++;
+	}
+	else if(*ptr == '+')
+	{
+		ptr++;
+	}
+
+	return sign * (long int)strtoul(ptr,endptr,base);
+}
+
+
+/**
+ * Convert the initial portion of a string into a long int
+ * @param ptr A pointer to the string to convert
+ * @return An long integer representation of the string
+ */
+
+long int atol(const char *ptr)
+{
+	return strtol(ptr, (char **) NULL, 10);
+}
Index: payloads/libpayload/libc/sys.c
===================================================================
--- payloads/libpayload/libc/sys.c	(revision 0)
+++ payloads/libpayload/libc/sys.c	(revision 0)
@@ -0,0 +1,107 @@
+/*
+ * This file is part of the libpayload project.
+ *
+ * Copyright (C) 2010 Sylvain Ageneau <sylvain_ageneau@yahoo.fr>
+ * 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.
+ * - The name of the author may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+/* Stubs for non-buffered IO. Since we don't actually have files, these only  */
+/* work for stdin (read), stdout and stderr (write). */
+
+#include <libpayload.h>
+
+#define STDIN 0
+#define STDOUT 1
+#define STDERR 2
+
+
+int open(const char *pathname, int flags, ...)
+{
+	int ret=0;
+
+	DEBUG_PRINT("Unimplemented\n");
+	return ret;
+}
+
+int close(int fd)
+{
+
+	DEBUG_PRINT("Unimplemented\n");
+	return 0;
+}
+
+ssize_t read(int fd, void *buf, size_t count)
+{
+	char* cur=buf;
+/*	DEBUG_PRINT("read %d,%x,%d\n",fd,buf,count); */
+
+	if(fd == STDIN)
+	{
+		*cur=getchar();		
+		return 1;
+	}
+	else if(fd == STDOUT)
+	{
+		DEBUG_PRINT("Unimplemented\n");
+	}
+	else if(fd == STDERR)
+	{
+		DEBUG_PRINT("Unimplemented\n");
+	}
+	else
+	{
+		DEBUG_PRINT("Unimplemented\n");
+	}
+
+	return 0;
+}
+
+ssize_t write(int fd, const void *buf, size_t count)
+{
+/*	DEBUG_PRINT("write %d,%x,%d\n",fd,buf,count); */
+	unsigned long i;
+	size_t ret=0;
+	char *cur=(char*)buf;
+
+	if(fd == STDOUT || fd == STDERR)
+	{
+		for(i=0;i<count;i++)
+		{
+			if(putchar(*cur) != EOF)
+			{
+				ret++;
+				cur++;
+			}
+		}
+/*		DEBUG_PRINT("wrote %d bytes, done %d\n",count, ret); */
+	}
+	else
+	{
+		DEBUG_PRINT("Unimplemented\n");
+	}
+
+	return ret;
+}
Index: payloads/libpayload/libc/stdio.c
===================================================================
--- payloads/libpayload/libc/stdio.c	(revision 0)
+++ payloads/libpayload/libc/stdio.c	(revision 0)
@@ -0,0 +1,237 @@
+/*
+ * This file is part of the libpayload project.
+ *
+ * Copyright (C) 2010 Sylvain Ageneau <sylvain_ageneau@yahoo.fr>
+ * 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.
+ * - The name of the author may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+/* Stubs for buffered IO. Since we don't actually have files, these only  */
+/* work for stdin (read), stdout and stderr (write). */
+
+#include "libpayload.h"
+
+
+int open(const char *pathname, int flags, ...);
+int close(int fd);
+ssize_t read(int fd, void *buf, size_t count);
+ssize_t write(int fd, const void *buf, size_t count);
+
+
+struct _IO_FILE
+{
+  int fd;
+  int ungotten; /* Was unget called on that stream ? */
+  char ungetbuf[0]; /* We support 1 unget, store the char here */
+};
+
+struct _IO_FILE __stdin = {
+  .fd=0,
+};
+
+struct _IO_FILE __stdout= {
+  .fd=1,
+};
+
+struct _IO_FILE  __stderr= {
+  .fd=2,
+};
+
+/**
+ * Examines the argument stream and returns its integer descriptor.
+ * @param stream A stream
+ * @return corresponding file descriptor
+ */
+
+int fileno (FILE *stream)
+{
+  return stream->fd;
+}
+
+/**
+ * opens the file whose name is the string pointed to by path and associates a stream with it.
+ * currently just a stub
+ * @param path location of the stream
+ * @param mode string indicating how you want to use that file
+ * @return corresponding file descriptor
+ */
+
+FILE *fopen(const char *path, const char *mode)
+{
+  DEBUG_PRINT("Not implemented\n");
+  return 0;
+}
+
+/**
+ * flushes the stream pointed to by fp (writing any buffered output data using fflush(3)) and closes the underlying
+ * file descriptor.
+ * currently just a stub
+ * @param fp the stream to close
+ * @return 0 on successful completion, EOF on error
+ */
+
+int fclose(FILE *fp)
+{
+  DEBUG_PRINT("Not implemented\n");
+  return EOF;
+}
+
+/**
+ * reads the next character from stream and returns it as an unsigned char cast to an int, or EOF on end of file or error.
+ * @param stream file to read from
+ * @return character read as an unsigned char cast to an int or EOF on end of file or error.
+ */
+
+int fgetc(FILE *stream)
+{
+  if(fileno(stream) == fileno(stdin)) {
+	if(!stream->ungotten) {
+	  return getchar();
+	}
+	else {
+	  stream->ungotten=0;
+	  return stream->ungetbuf[0];
+	}
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+
+  return EOF;
+}
+
+/**
+ * pushes c back to stream, cast to unsigned char, where it is available for subsequent read operations. Pushed-back characters
+ * will be returned in reverse order; only one pushback is guaranteed.
+ * @param c character to push back
+ * @param stream file to push back to
+ * @return returns c on success, or EOF on error.
+ */
+
+int ungetc(int c, FILE *stream)
+{
+  if(fileno(stream) == fileno(stdin)) {
+	stream->ungotten=1;
+	stream->ungetbuf[0]=c;
+	return c;
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+
+  return EOF;
+}
+
+/**
+ * writes the string s to stream, without its trailing '\0'.
+ * @param s string to write
+ * @param stream file to write to
+ * @return non-negative number on success, or EOF on error.
+ */
+
+int fputs(const char *s, FILE *stream)
+{
+  if(fileno(stream) == fileno(stdout) || fileno(stream) == fileno(stderr)) {
+	int n = 0;
+	while (*s) {
+	  putchar(*s++);
+	  n++;
+	}
+	return n;
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+
+  return EOF;
+}
+
+/**
+ * write nmemb elements of data, each size bytes long, to the stream pointed to by stream, obtaining  them  from  the
+ * location given by ptr.
+ * @param ptr location of the string to write
+ * @param size number of elements to write
+ * @param nmemb size of the elements to write
+ * @param stream file to write to
+ * @return number of items successfully written
+ */
+
+size_t fwrite(const void *ptr, size_t size, size_t nmemb,FILE *stream)
+{
+  if(fileno(stream) == fileno(stdout) || fileno(stream) == fileno(stderr)) {
+	return write(stream->fd,ptr,size*nmemb);
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+	
+  return 0;
+}
+
+
+/* size_t fread(void *ptr, size_t size, size_t nmemb, FILE *stream) */
+/* { */
+
+/* } */
+
+/**
+ * writes the character c, cast to an unsigned char, to stream.
+ * @param c character to write
+ * @param stream file to write to
+ * @return character written as an unsigned char cast to an int or EOF on error.
+ */
+
+int fputc(int c, FILE *stream)
+{
+  if(fileno(stream) == fileno(stdout) || fileno(stream) == fileno(stderr)) {
+	return putchar(c);
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+
+  return EOF;
+}
+
+/**
+ * prints to the stream pointed by stream according to format
+ * @param format string specifying the output format (see man(3) printf)
+ * @param stream file to write to
+ * @return the number of characters printed (not including the trailing '\0' used to end output to strings). Negative value on error.
+ */
+
+int fprintf(FILE *stream, const char *format, ...)
+{
+  if(fileno(stream) == fileno(stdout) || fileno(stream) == fileno(stderr)) {
+	int ret;
+	va_list ap;
+
+	va_start(ap, format);
+	ret = vprintf(format, ap);
+	va_end(ap);
+
+	return ret;
+  } else {
+	DEBUG_PRINT("Not implemented\n");
+  }
+
+  return -1;
+}
+
Index: payloads/tinyscheme/dynload.h
===================================================================
--- payloads/tinyscheme/dynload.h	(revision 0)
+++ payloads/tinyscheme/dynload.h	(revision 0)
@@ -0,0 +1,12 @@
+/* dynload.h */
+/* Original Copyright (c) 1999 Alexander Shendi     */
+/* Modifications for NT and dl_* interface: D. Souflis */
+
+#ifndef DYNLOAD_H
+#define DYNLOAD_H
+
+#include "scheme-private.h"
+
+SCHEME_EXPORT pointer scm_load_ext(scheme *sc, pointer arglist);
+
+#endif
Index: payloads/tinyscheme/hack.txt
===================================================================
--- payloads/tinyscheme/hack.txt	(revision 0)
+++ payloads/tinyscheme/hack.txt	(revision 0)
@@ -0,0 +1,236 @@
+
+                              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.
+
+     First of all, we need to assign a typeid to our new type. Typeids
+     in TinyScheme are small integers declared in an enum, very close to
+     the top; it begins with T_STRING. Add a new one at the end, say
+     T_MEMBLOCK. There can be at most 31 types, but you don't have to
+     worry about that limit yet.
+
+|    ...
+|      T_PORT,
+|      T_VECTOR,          /* remember to add a comma to the preceding item! */
+|      T_MEMBLOCK
+}     };
+
+     Then, some helper macros would be useful. Go to where isstring() and
+     the rest are defined and define:
+
+>    int ismemblock(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 ismemblock(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 procede 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(isstring(a)) {
+|               sc->free(strvalue(a));
+|          }
+>          else if(ismemblock(a)) {
+>               sc->free(strvalue(x));
+>          }
+|     }
+
+     There are no MEMBLOCK literals, so we don't concern ourselfs with
+     the READER part (yet!). We must cater to the PRINTER, though. We
+     add one case more in printatom().
+
+|     } else if (iscontinuation(l)) {
+|          p = "#<CONTINUATION>";
+>     } else if (ismemblock(l)) {
+>          p = "#<MEMORY BLOCK>";
+|     }
+
+     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. There is a huge enum with OP_XXX values.
+     That's where the op-codes are declared. For reasons of cohesion, we add
+     the new op-codes right after those for vectors:
+
+|   OP_VECSET,
+>   OP_MKBLOCK,
+>   OP_MEMBLOCKP,
+>   OP_BLOCKLEN,
+>   OP_BLOCKREF,
+>   OP_BLOCKSET,
+|   OP_NOT,
+
+     We add the predicate along the other predicates:
+
+|   OP_VECTORP,
+>   OP_BLOCKP,
+|   OP_EQ,
+
+     Op-codes are really just tags for a huge C switch, only this switch
+     is broke up in 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. INF_ARG as a maximum arity means "unlimited".
+
+|     {opexe_2, "vector-set!", 3, 3},    /* OP_VECSET */
+>     {opexe_2, "make-block", 1, 2},     /* OP_MKBLOCK */
+>     {opexe_2, "block-length", 1, 1},   /* OP_BLOCKLEN */
+>     {opexe_2, "block-ref", 2, 2},      /* OP_BLOCKREF */
+>     {opexe_2, "block-set!",3 ,3},      /* OP_BLOCKSET */
+
+     The predicate goes with the other predicates, in opexe_3.
+
+|     {opexe_3, "vector?", 1, 1},  /* OP_VECTORP, */
+>     {opexe_3, "block?", 1, 1},   /* OP_BLOCKP, */
+
+     All that remains is to write the actual processing in opexe_2, right
+     after OP_VECSET.
+
+>     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));
+>     }
+
+     Same for the predicate in opexe_3.
+
+|     case OP_VECTORP:     /* vector? */
+|          s_retbool(isvector(car(sc->args)));
+>     case OP_BLOCKP:     /* block? */
+>          s_retbool(ismemblock(car(sc->args)));
Index: payloads/tinyscheme/init.scm
===================================================================
--- payloads/tinyscheme/init.scm	(revision 0)
+++ payloads/tinyscheme/init.scm	(revision 0)
@@ -0,0 +1,581 @@
+;    Initialization file for TinySCHEME 1.39
+
+; Per R5RS, up to four deep compositions should be defined
+(write "Loading init.scm")
+(newline)
+
+(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)))))
+
+(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)))
+(define (max . lst)
+     (foldr (lambda (a b) (if (> a b) a b)) (car lst) (cdr lst)))
+(define (min . lst)
+     (foldr (lambda (a b) (if (< a b) a b)) (car lst) (cdr lst)))
+(define (succ x) (+ x 1))
+(define (pred x) (- x 1))
+(define (gcd a b)
+  (let ((aa (abs a))
+	(bb (abs b)))
+     (if (= bb 0)
+          aa
+          (gcd bb (remainder aa bb)))))
+(define (lcm a b)
+     (if (or (= a 0) (= b 0))
+          0
+          (abs (* (quotient a (gcd a b)) b))))
+
+(define call/cc call-with-current-continuation)
+
+(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) (string->anyatom str number?))
+
+(define (anyatom->string n pred)
+  (if (pred n)
+      (atom->string n)
+      (error "xxx->string: not a xxx" n)))
+  
+
+(define (number->string n) (anyatom->string n number?))    
+
+(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)))))
+
+
+;;;;; 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))
+
+;;;; Utility to ease macro creation
+(define (macro-expand form)
+     ((eval (get-closure-code (eval (car form)))) form))
+
+;;;; 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)))))))
+
+(write "Done loading init.scm")
+(newline)
+(gc-verbose #f)
Index: payloads/tinyscheme/scheme.c
===================================================================
--- payloads/tinyscheme/scheme.c	(revision 0)
+++ payloads/tinyscheme/scheme.c	(revision 0)
@@ -0,0 +1,4732 @@
+/* T I N Y S C H E M E    1 . 3 9
+ *   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"
+
+#if !defined(WIN32) && !defined(LIBPAYLOAD)
+# include <unistd.h>
+#endif
+#if USE_DL
+# include "dynload.h"
+#endif
+#if USE_MATH
+# include <math.h>
+#endif
+
+#if USE_READLINE && !defined(LIBPAYLOAD)
+#include <stdio.h>
+#include <readline/readline.h>
+#include <readline/history.h>
+#endif
+
+#if !defined(LIBPAYLOAD)
+#include <limits.h>
+#include <float.h>
+#include <ctype.h>
+#endif
+
+
+#if USE_READLINE 
+#if !defined(LIBPAYLOAD)
+#include <readline/readline.h>
+#include <readline/history.h>
+#else
+extern char *readline(const char *prompt);
+extern int getline(char *buffer, int len);
+#endif
+#endif
+
+#if USE_STRCASECMP && !defined(LIBPAYLOAD)
+#include <strings.h>
+# ifndef __APPLE__
+#  define stricmp strcasecmp
+# endif
+#endif
+
+#ifdef LIBPAYLOAD
+# ifndef LONG_MAX
+# define LONG_MAX	0x7fffffffffffffffL
+# 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 '`'
+
+/*
+ *  Basic memory allocation units
+ */
+
+#define banner "TinyScheme 1.39\n"
+
+#ifndef LIBPAYLOAD
+#include <string.h>
+#include <stdlib.h>
+#endif
+
+#if !defined(__APPLE__) && !defined(LIBPAYLOAD)
+# include <malloc.h>
+#else
+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 "> "
+#endif
+
+#ifndef InitFile
+#ifndef LIBPAYLOAD
+# define InitFile "init.scm"
+#else
+
+struct _EMBEDDED_FILE_
+{
+  char* name;
+  char* data;
+  unsigned int pos;	
+};
+
+extern struct _EMBEDDED_FILE_ _files[];
+
+# define InitFile _files[0].data
+#endif
+#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
+#if USE_FLOATS 
+static int is_zero_double(double x);
+#endif
+
+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 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) { 
+  return ((p)->_object._number.is_fixnum); 
+}
+INTERFACE INLINE int is_real(pointer p) { 
+  return (!(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 (is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
+INTERFACE double rvalue(pointer p)    { return (!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_integer(p)   (p)->_object._number.is_fixnum=1;
+#define set_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); }
+#define is_inport(p) (type(p)==T_PORT && p->_object._port->kind&port_input)
+#define is_outport(p) (type(p)==T_PORT && 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 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 pointer mk_empty_string(scheme *sc, int len, char fill);
+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(scheme*sc, 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 void 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 append(scheme *sc, pointer a, pointer b);
+static int list_length(scheme *sc, pointer a);
+static int eqv(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;
+  /* modulo 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;
+  if(res*e2<0) {    /* modulo should have same sign as second operand */
+	e2=labs(e2);
+	if(res>0) {
+	  res-=e2;
+	} else {
+	  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
+
+#if USE_FLOATS 
+static int is_zero_double(double x) {
+  return x<DBL_MIN && x>-DBL_MIN;
+}
+#endif
+
+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)
+	  {
+		DEBUG_PRINT("Failed to alloc %d bytes\n",CELL_SEGSIZE * sizeof(struct cell)+adj);
+		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(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) {
+    gc(sc,a, b);
+    if (sc->fcells < sc->last_cell_seg*8
+		|| 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) {
+    /* If not, try gc'ing some */
+    gc(sc, sc->NIL, sc->NIL);
+    x=find_consecutive_cells(sc,n);
+    if (x == sc->NIL) {
+      /* 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) {
+      /* If all fail, report failure */
+      sc->no_memory=1;
+      return sc->sink;
+    }
+  }
+  return (x);
+}
+
+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;
+}
+
+/* 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_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_integer(x);
+  return (x);
+}
+
+#if USE_FLOATS
+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_real(x);
+  return (x);
+}
+#endif
+
+static pointer mk_number(scheme *sc, num n) {
+#if USE_FLOATS 
+  if(n.is_fixnum) {
+#endif
+	return mk_integer(sc,n.value.ivalue);
+#if USE_FLOATS 
+  } else {
+	return mk_real(sc,n.value.rvalue);
+  }
+#endif
+}
+
+/* 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) {
+	strcpy(q, 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);
+
+  strvalue(x) = store_string(sc,len,str,0);
+  typeflag(x) = (T_STRING | T_ATOM);
+  strlength(x) = len;
+  return (x);
+}
+
+static pointer mk_empty_string(scheme *sc, int len, char fill) {
+  pointer x = get_cell(sc, sc->NIL, sc->NIL);
+
+  strvalue(x) = store_string(sc,len,0,fill);
+  typeflag(x) = (T_STRING | T_ATOM);
+  strlength(x) = len;
+  return (x);
+}
+
+INTERFACE static pointer mk_vector(scheme *sc, int len) {
+  pointer x=get_consecutive_cells(sc,len/2+len%2+1);
+  typeflag(x) = (T_VECTOR | T_ATOM);
+  ivalue_unchecked(x)=len;
+  set_integer(x);
+  fill_vector(x,sc->NIL);
+  return x;
+}
+
+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++) { 
+	sprintf(name,"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;
+#if USE_FLOATS
+  int has_dec_point=0;
+  int has_fp_exp = 0;
+#endif
+
+#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 USE_FLOATS
+	if (c == '.') { 
+	  has_dec_point=1; 
+	  c = *p++; 
+	} 
+#endif
+	if (!isdigit(c)) { 
+	  return (mk_symbol(sc, strlwr(q))); 
+	} 
+  }
+#if USE_FLOATS 
+  else if (c == '.') { 
+	has_dec_point=1; 
+	c = *p++; 
+	if (!isdigit(c)) { 
+	  return (mk_symbol(sc, strlwr(q))); 
+	} 
+  }
+#endif
+  else if (!isdigit(c)) { 
+	return (mk_symbol(sc, strlwr(q))); 
+  }
+
+  for ( ; (c = *p) != 0; ++p) {
+	if (!isdigit(c)) {
+#if USE_FLOATS 
+	  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;
+		  }
+		}  
+	  }
+#endif    
+	  return (mk_symbol(sc, strlwr(q)));
+	}
+  }
+#if USE_FLOATS 
+  if(has_dec_point) {
+	return mk_real(sc,atof(q));
+  }
+#endif
+  return (mk_integer(sc, atol(q)));
+}
+
+/* make constant */
+static pointer mk_sharp_const(scheme *sc, char *name) {
+  long    x;
+  char    tmp[256];
+
+  if (!strcmp(name, "t"))
+	return (sc->T);
+  else if (!strcmp(name, "f"))
+	return (sc->F);
+  else if (*name == 'o') {/* #o (octal) */
+	snprintf(tmp, sizeof(tmp), "0%s", name+1);
+	x=strtol(tmp,0,8);
+	return (mk_integer(sc, x));
+  } else if (*name == 'd') {    /* #d (decimal) */
+	x=strtol(name+1,0,10);
+	return (mk_integer(sc, x));
+  } else if (*name == 'x') {    /* #x (hex) */
+	snprintf(tmp, sizeof(tmp), "0x%s", name+1);
+	x=strtol(tmp,0,16);
+	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) {
+	  char* endptr;
+	  long c1=strtol(name+2,&endptr,16);
+
+	  if(*(name+2)!='\0' && *endptr=='\0' // if the string contained a valid long int
+		 && c1<256) {
+		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 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];
+    sprintf(msg,"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=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;
+  }
+  return fin!=0;
+}
+
+static void file_pop(scheme *sc) {
+  sc->nesting=sc->nesting_stack[sc->file_i];
+  if(sc->file_i!=0) {
+	port_close(sc,sc->loadport,port_input);
+	sc->file_i--;
+	sc->loadport->_object._port=sc->load_stack+sc->file_i;
+#ifndef USE_READLINE
+	if(file_interactive(sc)) {
+	  putstr(sc,"prompt");
+	}
+#endif
+  }
+}
+
+static int file_interactive(scheme *sc) {
+  return sc->file_i==0 && fileno(sc->load_stack[0].rep.stdio.file)==fileno(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;
+  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) {
+  char *rw;
+  port *pt;
+  pt=(port*)sc->malloc(sizeof(port));
+  if(pt==0) {
+    return 0;
+  }
+  if(prop==(port_input|port_output)) {
+    rw="a+";
+  } else if(prop==port_output) {
+    rw="w";
+  } else {
+    rw="r";
+  }
+  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);
+}
+
+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) {
+      fclose(pt->rep.stdio.file);
+    }
+    pt->kind=port_free;
+  }
+}
+
+/* get new character from input file */
+static int inchar(scheme *sc) {
+  int c;
+  port *pt;
+ again:
+  pt=sc->inport->_object._port;
+  c=basic_inchar(sc,pt);
+  if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {
+    file_pop(sc);
+	if(sc->nesting!=0) {
+	  return EOF;
+	} else {
+	  return '\n';
+	}
+	goto again;
+  }
+  return c;
+}
+
+#if USE_READLINE
+
+static char* _line;
+static int _len;
+static int _pos;
+#ifdef LIBPAYLOAD
+#define READLINE_BUFSIZE 256
+static char readline_buf[READLINE_BUFSIZE];
+#endif
+
+// Don't use this directly, use getc_readline instead
+static int __inchar_readline() {
+  int ret;
+
+  if(!_line) {
+	do {
+#ifdef LIBPAYLOAD
+	  printf(prompt);
+	  strcpy(readline_buf,"");
+	  getline(readline_buf,READLINE_BUFSIZE);
+	  _line=readline_buf;
+#else
+	  _line=readline(prompt);
+#endif
+	  if(!_line) // User entered an empty line with EOF
+		return EOF;
+	  _len=strlen(_line);
+	} while(_len == 0);
+
+	_pos=0;
+  }	
+
+  if(_pos==_len) {
+	ret='\n';
+#ifndef LIBPAYLOAD
+	// libpayload's readline doesn't allocate a new buffer after each call like gnu readline
+	free(_line);
+#endif
+	_line=0;
+  } else {
+	ret=_line[_pos];
+  }
+
+  ++_pos;
+
+  return ret;
+}
+
+static char ungetbuf[1]; // We only support 1 unget
+static int ungotten=0;
+
+int getc_readline()
+{
+  if(!ungotten) {
+	return __inchar_readline();
+  } else {
+	ungotten=0;
+	return ungetbuf[0];
+  }	
+}
+
+int ungetc_readline(int c)
+{
+  ungetbuf[0]=c;
+  ungotten=1;
+}
+
+#endif
+
+static int basic_inchar(scheme*sc, port *pt) {
+  if(pt->kind&port_file) {
+#if USE_READLINE
+	if(file_interactive(sc))
+	  {
+		char c=getc_readline();
+		return c;
+	  } 
+	else
+#endif
+	  {
+		char c=fgetc(pt->rep.stdio.file);
+		return c;
+	  }
+  } 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) {
+#if USE_READLINE
+	if(file_interactive(sc))
+	  {
+		ungetc_readline(c);
+	  } 
+	else
+#endif
+	  ungetc(c,pt->rep.stdio.file);
+  } else {
+    if(pt->rep.string.curr!=pt->rep.string.start) {
+      --pt->rep.string.curr;
+    }
+  }
+}
+
+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;
+      }
+    }
+  }
+}
+
+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++;
+      }
+    }
+  }
+}
+
+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;
+    }
+  }
+}
+
+/* read characters up to delimiter, but cater to character constants */
+static char   *readstr_upto(scheme *sc, char *delim) {
+  char   *p = sc->strbuff;
+
+  while (!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, st_oct3 } 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:
+	case st_oct3:
+	  if (c < '0' || c > '7')
+		{
+		  if (state==st_oct1)
+			return sc->F;
+
+		  *p++=c1;
+		  backchar(sc, c);
+		  state=st_ok;
+		}
+	  else
+		{
+		  c1=(c1<<3)+(c-'0');
+		  switch (state)
+			{
+			case st_oct1:
+			  state=st_oct2;
+			  break;
+			case st_oct2:
+			  state=st_oct3;
+			  break;
+			default:
+			  *p++=c1;
+			  state=st_ok;
+			  break;
+			}
+		}
+	  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 void skipspace(scheme *sc) {
+  int c;
+  while (isspace(c=inchar(sc)))
+	;
+  if(c!=EOF) {
+	backchar(sc,c);
+  }
+}
+
+/* get token */
+static int token(scheme *sc) {
+  int c;
+  skipspace(sc);
+  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)
+	  ;
+	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)
+		;
+	  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;
+	strcpy(p, "#<PORT>");
+  } else if (is_number(l)) {
+	p = sc->strbuff;
+	if(is_integer(l)) {
+	  sprintf(p, "%ld", ivalue_unchecked(l));
+	} else {
+#if USE_FLOATS
+#ifndef LIBPAYLOAD
+	  sprintf(p, "%.10g", rvalue_unchecked(l));
+#else
+	  char* tmp=dtoa_dec(rvalue_unchecked(l));
+	  sprintf(p, "%s", tmp);
+	  free(tmp);
+#endif
+#endif
+	}
+  } 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 ' ':
+		sprintf(p,"#\\space"); break;
+	  case '\n':
+		sprintf(p,"#\\newline"); break;
+	  case '\r':
+		sprintf(p,"#\\return"); break;
+	  case '\t':
+		sprintf(p,"#\\tab"); break;
+	  default:
+#if USE_ASCII_NAMES
+		if(c==127) {
+		  strcpy(p,"#\\del"); break;
+		} else if(c<32) {
+		  strcpy(p,"#\\"); strncat(p,charnames[c],32); break;
+		}
+#else
+		if(c<32) {
+		  sprintf(p,"#\\x%x",c); break;
+		}
+#endif
+		sprintf(p,"#\\%c",c); break;
+	  }
+	}
+  } else if (is_symbol(l)) {
+	p = symname(l);
+  } else if (is_proc(l)) {
+	p = sc->strbuff;
+	sprintf(p, "#<%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;
+	sprintf(p, "#<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 */
+static pointer append(scheme *sc, pointer a, pointer b) {
+  pointer p = b, q;
+
+  if (a != sc->NIL) {
+	a = reverse(sc, a);
+	while (a != sc->NIL) {
+	  q = cdr(a);
+	  cdr(a) = p;
+	  p = a;
+	  a = q;
+	}
+  }
+  return (p);
+}
+
+/* equivalence of atoms */
+static 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))
+	  return num_eq(nvalue(a),nvalue(b));
+	else
+	  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) {
+#if USE_ERROR_HOOK
+  pointer x;
+  pointer hdl=sc->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, (s)), 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, (s)), 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));
+	}
+	s_goto(sc,OP_T0LVL);
+
+  case OP_T0LVL: /* top level */
+	if(file_interactive(sc)) {
+	  putstr(sc,"\n");
+	}
+	sc->nesting=0;
+	dump_stack_reset(sc); 
+	sc->envir = sc->global_env;
+	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);
+#ifndef USE_READLINE
+	if (file_interactive(sc)) {
+	  putstr(sc,prompt);
+	}
+#endif
+	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) {
+	  if(sc->inport==sc->loadport) {
+		sc->args=sc->NIL;
+		s_goto(sc,OP_QUIT);
+	  } else {
+		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)) {
+	  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);
+
+  case OP_LAMBDA:     /* lambda */
+	s_return(sc,mk_closure(sc, sc->code, sc->envir));
+
+  case OP_MKCLOSURE: /* make-closure */
+	x=car(sc->args);
+	if(car(x)==sc->LAMBDA) {
+	  x=cdr(x);
+	}
+	if(cdr(sc->args)==sc->NIL) {
+	  y=sc->envir;
+	} else {
+	  y=cadr(sc->args);
+	}
+	s_return(sc,mk_closure(sc, x, y));
+
+  case OP_QUOTE:      /* quote */
+	x=car(sc->code);
+	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 */
+	  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)) {
+
+		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);
+	}
+	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:
+	sprintf(sc->strbuff, "%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 */
+	  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:
+	sprintf(sc->strbuff, "%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(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:
+	x=car(sc->args);
+	if(cdr(sc->args)==sc->NIL) {
+	  Error_0(sc,"expt: needs two arguments");
+	} else {
+	  pointer y=cadr(sc->args);
+	  s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
+	}
+
+  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);
+	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 USE_FLOATS 
+	  if (!is_zero_double(rvalue(car(x))))
+		v=num_div(v,nvalue(car(x)));
+#else
+	  if (rvalue(car(x)) != 0)
+		v=num_intdiv(v,nvalue(car(x)));
+#endif
+	  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));
+	if(*s=='#') {
+	  s_return(sc, mk_sharp_const(sc, s+1));
+	} else {
+	  s_return(sc, mk_atom(sc, s));
+	}
+  }
+
+  case OP_SYM2STR: /* symbol->string */
+	x=mk_string(sc,symname(car(sc->args)));
+	setimmutable(x);
+	s_return(sc,x);
+  case OP_ATOM2STR: /* atom->string */
+	x=car(sc->args);
+	if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
+	  char *p;
+	  int len;
+	  atom2str(sc,x,0,&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);
+	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(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:
+	sprintf(sc->strbuff, "%d: illegal operator", sc->op);
+	Error_0(sc,sc->strbuff);
+  }
+  return sc->T;
+}
+
+static int list_length(scheme *sc, pointer a) {
+  int v=0;
+  pointer x;
+  for (x = a, v = 0; is_pair(x); x = cdr(x)) {
+	++v;
+  }
+  if(x==sc->NIL) {
+	return v;
+  }
+  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? */
+	pointer slow, fast;
+	slow = fast = car(sc->args);
+	while (1) {
+	  if (!is_pair(fast)) s_retbool(fast == sc->NIL);
+	  fast = cdr(fast);
+	  if (!is_pair(fast)) s_retbool(fast == sc->NIL);
+	  fast = cdr(fast);
+	  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 */
+		s_retbool(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:
+	sprintf(sc->strbuff, "%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 */
+	if(sc->args==sc->NIL) {
+	  s_return(sc,sc->NIL);
+	}
+	x=car(sc->args);
+	if(cdr(sc->args)==sc->NIL) {
+	  s_return(sc,sc->args);
+	}
+	for (y = cdr(sc->args); y != sc->NIL; y = cdr(y)) {
+	  x=append(sc,x,car(y));
+	}
+	s_return(sc,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_OUTSTRING: /* open-output-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_OUTSTRING:    prop=port_output; 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);
+  }
+#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:
+	  if(sc->inport==sc->loadport) {
+		sc->args=sc->NIL;
+		s_goto(sc,OP_QUIT);
+	  } else {
+		s_return(sc,sc->EOF_OBJ);
+	  }
+	  /*
+	   * 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, "();\t\n\r ")));
+	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, "();\t\n\r "))) == 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_RPAREN) {
+	  int c = inchar(sc);
+	  if (c != '\n') backchar(sc,c);
+	  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;
+	  putstr(sc," ");
+	  s_goto(sc,OP_P0LIST);
+	}
+  }
+
+  default:
+	sprintf(sc->strbuff, "%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:
+	sprintf(sc->strbuff, "%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_num_integer(pointer p) { 
+  return is_number(p) && ((p)->_object._number.is_fixnum); 
+}
+static int is_nonneg(pointer p) {
+  return is_num_integer(p) && ivalue(p)>=0;
+}
+
+/* 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"},
+  {0,"input port"},
+  {0,"output_port"},
+  {is_environment, "environment"},
+  {is_pair, "pair"},
+  {0, "pair or '()"},
+  {is_character, "character"},
+  {is_vector, "vector"},
+  {is_number, "number"},
+  {is_num_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) {
+  int count=0;
+  int old_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[512];
+      int ok=1;
+      int n=list_length(sc,sc->args);
+      
+      /* Check number of arguments */
+      if(n<pcd->min_arity) {
+		ok=0;
+		sprintf(msg,"%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;
+		sprintf(msg,"%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_INPORT[0]) {
+			  if(!is_inport(arg)) break;
+			} else if(j==TST_OUTPORT[0]) {
+			  if(!is_outport(arg)) break;
+            } else 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;
+			sprintf(msg,"%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;
+      }
+    }
+    old_op=sc->op;
+    if (pcd->func(sc, (enum scheme_opcodes)sc->op) == sc->NIL) {
+      return;
+    }
+    if(sc->no_memory) {
+      fprintf(stderr,"No memory!\n");
+      return;
+    }
+    count++;
+  }
+}
+
+/* ========== 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_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,
+#if USE_FLOATS 
+  mk_real,
+#endif
+  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_vector,
+  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;
+  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*");
+
+  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;
+
+  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]);
+  }
+}
+
+void scheme_load_file(scheme *sc, FILE *fin) {
+  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(fileno(fin)==fileno(stdin)) {
+    sc->interactive_repl=1;
+  }
+  sc->inport=sc->loadport;
+  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;
+  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_apply0(scheme *sc, const char *procname) {
+  pointer carx=mk_symbol(sc,procname);
+  pointer cdrx=sc->NIL;
+
+  dump_stack_reset(sc); 
+  sc->envir = sc->global_env;
+  sc->code = cons(sc,carx,cdrx);
+  sc->interactive_repl=0;
+  sc->retcode=0;
+  Eval_Cycle(sc,OP_EVAL);
+}
+
+void scheme_call(scheme *sc, pointer func, pointer args) { 
+  dump_stack_reset(sc); 
+  sc->envir = sc->global_env; 
+  sc->args = args; 
+  sc->code = func; 
+  sc->interactive_repl =0; 
+  sc->retcode = 0; 
+  Eval_Cycle(sc, OP_APPLY); 
+} 
+#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;
+
+#ifdef LIBPAYLOAD
+	argc=1;
+#endif
+  
+	if(argc==1) {
+	  printf(banner);
+	}
+	if(argc==2 && strcmp(argv[1],"-?")==0) {
+	  printf("Usage: %s [-? | <file1> <file2> ... | -1 <file> <arg1> <arg2> ...]\n\tUse - as filename for stdin.\n",argv[0]);
+	  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++;
+#ifndef LIBPAYLOAD
+	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_file(&sc,fin);
+		} 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);
+#else
+	scheme_load_string(&sc,file_name);
+	if(sc.retcode!=0) {
+	  fprintf(stderr,"Errors encountered reading %s\n",file_name);
+	}
+
+#endif
+
+	if(argc==1) {
+	  scheme_load_file(&sc,stdin);
+	}
+	retcode=sc.retcode;
+	scheme_deinit(&sc);
+  
+	return retcode;
+  }
+
+#endif
Index: payloads/tinyscheme/scheme.h
===================================================================
--- payloads/tinyscheme/scheme.h	(revision 0)
+++ payloads/tinyscheme/scheme.h	(revision 0)
@@ -0,0 +1,234 @@
+/* SCHEME.H */
+
+#ifndef _SCHEME_H
+#define _SCHEME_H
+
+#ifndef LIBPAYLOAD
+#include <stdio.h>
+#else
+#include <libpayload.h>
+#include <libpayload-config.h>
+#endif
+
+#define DEBUG_PRINT(fmt, ...) \
+	do { if (DEBUG) printf("%s:%d:%s(): " fmt, __FILE__,		\
+						   __LINE__, __func__, ##__VA_ARGS__); } while (0)
+
+
+/*
+ * 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_FLOATS 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_FLOATS         /* If float support is needed */
+# define USE_FLOATS 1
+#endif
+
+#if !defined(USE_MATH) && defined(USE_FLOATS) /* If math support is needed (requires USE_FLOATS */
+# 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
+
+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_string(scheme *sc, const char *cmd);
+void scheme_apply0(scheme *sc, const char *procname);
+SCHEME_EXPORT pointer scheme_apply1(scheme *sc, const char *procname, pointer);
+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);
+#if USE_FLOATS 
+pointer mk_real(scheme *sc, double num);
+#endif
+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_foreign_func(scheme *sc, foreign_func f);
+void putstr(scheme *sc, const char *s);
+
+
+#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);
+#if USE_FLOATS 
+  pointer (*mk_real)(scheme *sc, double num);
+#endif
+  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_vector)(pointer p);
+  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
+
+#endif
+
Index: payloads/tinyscheme/Manual.txt
===================================================================
--- payloads/tinyscheme/Manual.txt	(revision 0)
+++ payloads/tinyscheme/Manual.txt	(revision 0)
@@ -0,0 +1,449 @@
+
+
+                       TinySCHEME Version 1.38
+
+                    "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
+     refered 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,
+     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.          
+     
+          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.
+
+
+
+
+
+
+
+
Index: payloads/tinyscheme/tinyscheme.ldscript
===================================================================
--- payloads/tinyscheme/tinyscheme.ldscript	(revision 0)
+++ payloads/tinyscheme/tinyscheme.ldscript	(revision 0)
@@ -0,0 +1,90 @@
+/*
+ * This file is part of the libpayload project.
+ *
+ * Copyright (C) 2008 Advanced Micro Devices, Inc.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ * 1. Redistributions of source code must retain the above copyright
+ *    notice, this list of conditions and the following disclaimer.
+ * 2. 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.
+ * 3. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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.
+ */
+
+BASE_ADDRESS = 0x100000;
+
+OUTPUT_FORMAT(elf32-i386)
+OUTPUT_ARCH(i386)
+
+ENTRY(_entry)
+
+/* HEAP_SIZE = 16384; */
+HEAP_SIZE = 262144;
+STACK_SIZE = 16384;
+
+SECTIONS
+{
+	. = BASE_ADDRESS;
+
+	. = ALIGN(16);
+	_start = .;
+
+	.text : {
+		*(.text._entry)
+		*(.text)
+		*(.text.*)
+	}
+
+	.rodata : {
+		*(.rodata)
+		*(.rodata.*)
+	}
+
+	.data : {
+		*(.data)
+		*(.data.*)
+	}
+
+	_edata = .;
+
+	.bss : {
+		*(.sbss)
+		*(.sbss.*)
+		*(.bss)
+		*(.bss.*)
+		*(COMMON)
+
+		/* Stack and heap */
+
+		. = ALIGN(16);
+		_heap = .;
+		. += HEAP_SIZE;
+		. = ALIGN(16);
+		_eheap = .;
+
+		_estack = .;
+		. += STACK_SIZE;
+		. = ALIGN(16);
+		_stack = .;
+	}
+
+	_end = .;
+
+	/DISCARD/ : { *(.comment) }
+}
Index: payloads/tinyscheme/BUILDING
===================================================================
--- payloads/tinyscheme/BUILDING	(revision 0)
+++ payloads/tinyscheme/BUILDING	(revision 0)
@@ -0,0 +1,139 @@
+	Building TinyScheme
+	-------------------
+
+The included makefile includes logic for Linux, Solaris and Win32, and can
+readily serve as an example for other OSes, especially Unixes. There are
+a lot of compile-time flags in TinyScheme (preprocessor defines) that can trim
+unwanted features. See next section. 'make all' and 'make clean' function as
+expected.
+
+Autoconfing TinyScheme was once proposed, but the distribution would not be
+so small anymore. There are few platform dependencies in TinyScheme, and in
+general compiles out of the box.
+
+	 Customizing
+     -----------
+
+     The following symbols are defined to default values in scheme.h.
+     Use the -D flag of cc to set to either 1 or 0.
+
+     STANDALONE
+     Define this to produce a standalone interpreter.
+
+     USE_MATH
+     Includes math routines.
+
+     USE_CHAR_CLASSIFIERS
+     Includes character classifier procedures.
+
+     USE_ASCII_NAMES
+     Enable extended character notation based on ASCII names.
+
+     USE_STRING_PORTS
+     Enables string ports.
+
+     USE_ERROR_HOOK
+     To force system errors through user-defined error handling.
+     (see "Error handling")
+
+     USE_TRACING
+     To enable use of TRACING.
+
+     USE_COLON_HOOK
+     Enable use of qualified identifiers. (see "Colon Qualifiers - Packages")
+     Defining this as 0 has the rather drastic consequence that any code using
+     packages will stop working, and will have to be modified. It should only
+     be used if you *absolutely* need to use '::' in identifiers.
+
+     USE_STRCASECMP
+     Defines stricmp as strcasecmp, for Unix.
+
+     STDIO_ADDS_CR
+     Informs TinyScheme that stdio translates "\n" to "\r\n". For DOS/Windows.
+
+     USE_DL
+     Enables dynamically loaded routines. If you define this symbol, you
+     should also include dynload.c in your compile.
+
+     USE_PLIST
+     Enables property lists (not Standard Scheme stuff). Off by default.
+     
+     USE_NO_FEATURES
+     Shortcut to disable USE_MATH, USE_CHAR_CLASSIFIERS, USE_ASCII_NAMES,
+     USE_STRING_PORTS, USE_ERROR_HOOK, USE_TRACING, USE_COLON_HOOK,
+     USE_DL.
+
+	 USE_SCHEME_STACK
+	 Enables 'cons' stack (the alternative is a faster calling scheme, which 
+	 breaks continuations). Undefine it if you don't care about strict compatibility
+	 but you do care about faster execution.
+
+
+     OS-X tip
+     --------
+	 I don't have access to OS-X, but Brian Maher submitted the following tip:
+
+[1] Download and install fink (I installed fink in
+/usr/local/fink)
+[2] Install the 'dlcompat' package using fink as such:
+> fink install dlcompat
+[3] Make the following changes to the
+tinyscheme-1.32.tar.gz
+
+diff -r tinyscheme-1.32/dynload.c
+tinyscheme-1.32-new/dynload.c
+24c24
+< #define SUN_DL
+---
+> 
+Only in tinyscheme-1.32-new/: dynload.o
+Only in tinyscheme-1.32-new/: libtinyscheme.a Only in tinyscheme-1.32-new/: libtinyscheme.so diff -r tinyscheme-1.32/makefile tinyscheme-1.32-new/makefile
+33,34c33,43
+< LD = gcc
+< LDFLAGS = -shared
+---
+> #LD = gcc
+> #LDFLAGS = -shared
+> #DEBUG=-g -Wno-char-subscripts -O
+> #SYS_LIBS= -ldl
+> #PLATFORM_FEATURES= -DSUN_DL=1
+> 
+> # Mac OS X
+> CC = gcc
+> CFLAGS = -I/usr/local/fink/include
+> LD = gcc
+> LDFLAGS = -L/usr/local/fink/lib
+37c46
+< PLATFORM_FEATURES= -DSUN_DL=1
+---
+> PLATFORM_FEATURES= -DSUN_DL=1 -DOSX
+60c69
+<       $(CC) -I. -c $(DEBUG) $(FEATURES)
+$(DL_FLAGS) $<
+---
+>       $(CC) $(CFLAGS) -I. -c $(DEBUG)
+$(FEATURES) $(DL_FLAGS) $<
+66c75
+<       $(CC) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 
+---
+>       $(CC) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS)
+$(SYS_LIBS)
+Only in tinyscheme-1.32-new/: scheme
+diff -r tinyscheme-1.32/scheme.c
+tinyscheme-1.32-new/scheme.c
+60,61c60,61
+< #ifndef macintosh
+< # include <malloc.h>
+---
+> #ifdef OSX
+> /* Do nothing */
+62a63,65
+> # ifndef macintosh
+> #  include <malloc.h>
+> # else
+77c80,81
+< #endif /* macintosh */
+---
+> # endif /* macintosh */
+> #endif /* !OSX */
+Only in tinyscheme-1.32-new/: scheme.o
Index: payloads/tinyscheme/MiniSCHEMETribute.txt
===================================================================
--- payloads/tinyscheme/MiniSCHEMETribute.txt	(revision 0)
+++ payloads/tinyscheme/MiniSCHEMETribute.txt	(revision 0)
@@ -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")
Index: payloads/tinyscheme/scheme-private.h
===================================================================
--- payloads/tinyscheme/scheme-private.h	(revision 0)
+++ payloads/tinyscheme/scheme-private.h	(revision 0)
@@ -0,0 +1,187 @@
+/* scheme-private.h */
+
+#ifndef _SCHEME_PRIVATE_H
+#define _SCHEME_PRIVATE_H
+
+#include "scheme.h"
+/*------------------ Ugly internals -----------------------------------*/
+/*------------------ Of interest only to FFI users --------------------*/
+
+
+enum scheme_port_kind { 
+  port_free=0, 
+  port_file=1, 
+  port_string=2, 
+  port_input=16, 
+  port_output=32 
+};
+
+typedef struct port {
+  unsigned char kind;
+  union {
+    struct {
+      FILE *file;
+      int closeit;
+    } 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 */
+
+/* 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 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];
+char    strbuff[256];
+
+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);
+
+#endif
Index: payloads/tinyscheme/opdefines.h
===================================================================
--- payloads/tinyscheme/opdefines.h	(revision 0)
+++ payloads/tinyscheme/opdefines.h	(revision 0)
@@ -0,0 +1,191 @@
+    _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, "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,  1,       TST_ANY,                         OP_ATOM2STR         )
+    _OP_DEF(opexe_2, "string->symbol",                 1,  1,       TST_STRING,                      OP_STR2SYM          )
+    _OP_DEF(opexe_2, "string->atom",                   1,  1,       TST_STRING,                      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_PAIR,                        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           )
+    _OP_DEF(opexe_4, "put",                            3,  3,       TST_NONE,                        OP_PUT              )
+    _OP_DEF(opexe_4, "get",                            2,  2,       TST_NONE,                        OP_GET              )
+    _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-output-string",             1,  1,       TST_STRING,                      OP_OPEN_OUTSTRING   )
+    _OP_DEF(opexe_4, "open-input-output-string",       1,  1,       TST_STRING,                      OP_OPEN_INOUTSTRING )
+#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
Index: payloads/tinyscheme/CHANGES
===================================================================
--- payloads/tinyscheme/CHANGES	(revision 0)
+++ payloads/tinyscheme/CHANGES	(revision 0)
@@ -0,0 +1,208 @@
+     Change Log
+     ----------
+     Version 1.39
+          Drew Yao fixed buffer overflow problems in mk_sharp_const.
+     Version 1.38
+          Interim release until the rewrite, mostly incorporating modifications from 
+          Kevin Cozens. Small addition for Cygwin in the makefile, and modifications
+          by Andrew Guenther for Apple platforms.
+     Version 1.37
+          Joe Buehler submitted reserve_cells.
+     Version 1.36
+	  Joe Buehler fixed a patch in the allocator.
+	  Alexander Shendi moved the comment handling in the scanner, which 
+	  fixed an obscure bug for which Mike E had provided a patch as well.
+	  Kevin Cozens has submitted some fixes and modifications which have not
+	  been incorporated yet in their entirety.
+     Version 1.35
+	  Todd Showalter discovered that the number of free cells reported 
+	  after GC was incorrect, which could also cause unnecessary allocations.
+	 Version 1.34
+	  Long missing version. Lots of bugfixes have accumulated in my email, so
+	  I had to start using them. In this version, Keenan Pepper has submitted
+	  a bugfix for the string comparison library procedure, Wouter Boeke 
+	  modified some code that was casting to the wrong type and crashed on
+	  some machines, "SheppardCo" submitted a replacement "modulo" code and
+	  Scott Fenton submitted lots of corrections that shut up some compiler
+	  warnings. Brian Maher submitted instructions on how to build on OS-X.
+	  I have to dig deeper into my mailbox and find earlier emails, too.
+     Version 1.33
+	  Charles Hayden fixed a nasty GC bug of the new stack frame, while in
+	  the process of porting TinyScheme to C++. He also submitted other 
+	  changes, and other people also had comments or requests, but the GC
+	  bug was so important that this version is put through the door to 
+	  correct it.
+     Version 1.32
+	  Stephen Gildea put some quality time on TinyScheme again, and made
+	  a whole lot of changes to the interpreter that made it noticeably 
+	  faster.
+     Version 1.31
+          Patches to the hastily-done version 1.30. Stephen Gildea fixed
+	  some things done wrongly, and Richard Russo fixed the makefile
+	  for building on Windows. Property lists (heritage from MiniScheme)
+	  are now optional and have dissappeared from the interface. They
+	  should be considered as deprecated.
+     Version 1.30
+	  After many months, I followed Preston Bannister's advice of
+	  using macros and a single source text to keep the enums and the
+	  dispatch table in sync, and I used his contributed "opdefines.h".
+	  Timothy Downs contributed a helpful function, "scheme_call".
+	  Stephen Gildea contributed new versions of the makefile and 
+	  practically all other sources. He created a built-in STRING-APPEND,
+	  and fixed a lot of other bugs.
+	  Ruhi Bloodworth reported fixes necessary for OS X and a small
+	  bug in dynload.c.
+     Version 1.29
+	  The previous version contained a lot of corrections, but there
+	  were a lot more that still wait on a sheet of paper lost in a
+	  carton someplace after my house move... Manuel Heras-Gilsanz
+	  noticed this and resent his own contribution, which relies on
+	  another bugfix that v.1.28 was missing: a problem with string
+	  output, that this version fixes. I hope other people will take
+	  the time to resend their contributions, if they didn't make it
+	  to v.1.28.
+     Version 1.28
+	  Many people have contacted me with bugfixes or remarks in
+	  the three months I was inactive. A lot of them spotted that 
+	  scheme_deinit crashed while reporting gc results. They suggested
+	  that sc->outport be set to NIL in scheme_deinit, which I did.
+	  Dennis Taylor remarked that OP_VALUEPRINT reset sc->value instead
+	  of preserving it. He submitted a modification which I adopted 
+	  partially. David Hovemeyer sent me many little changes, that you
+	  will find in version 1.28, and Partice Stoessel modified the 
+	  float reader to conform to R5RS.
+     Version 1.27
+          Version 1.27 is the successor of 1.25. Bug fixes only, but I had to
+          release them so that everybody can profit. 'Backchar' tried to write
+          back to the string, which obviously didn't work for const strings.
+          'Substring' didn't check for crossed start and end indices. Defines
+          changed to restore the ability to compile under MSVC.
+     Version 1.26
+          Version 1.26 was never released. I changed a lot of things, in fact
+          too much, even the garbage collector, and hell broke loose. I'll
+          try a more gradual approach next time.
+     Version 1.25
+          Types have been homogenized to be able to accomodate a different
+	  representation. Plus, promises are no longer closures. Unfortunately,
+	  I discovered that continuations and force/delay do not pass the SCM
+	  test (and never did)... However, on the bright side, what little
+	  modifications I did had a large impact on the footprint: 
+	  USE_NO_FEATURES now produces an object file of 63960 bytes on Linux!
+     Version 1.24
+	  SCM tests now pass again after change in atom2str.
+     Version 1.23
+          Finally I managed to mess it up with my version control. Version
+	  1.22 actually lacked some of the things I have been fixing in the
+	  meantime. This should be considered as a complete replacement for
+	  1.22.
+     Version 1.22
+          The new ports had a bug in LOAD. MK_CLOSURE is introduced.
+	  Shawn Wagner inquired about string->number and number->string.
+	  I added string->atom and atom->string and defined the number
+	  functions from them. Doing that, I fixed WRITE applied to symbols
+	  (it didn't quote them). Unfortunately, minimum build is now
+	  slightly larger than 64k... I postpone action because Jason's idea
+	  might solve it elegantly.
+     Version 1.21
+          Jason Felice submitted a radically different datatype representation
+	  which he had implemented. While discussing its pros and cons, it
+	  became apparent that the current implementation of ports suffered
+	  from a grave fault: ports were not garbage-collected. I changed the
+	  ports to be heap-allocated, which enabled the use of string ports
+	  for loading. Jason also fixed errors in the garbage collection of 
+	  vectors. USE_VERBATIM is gone. "ssp_compiler.c" has a better solution
+	  on HTML generation. A bug involving backslash notation in strings
+	  has been fixed. '-c' flag now executes next argument as a stream of
+	  Scheme commands. Foreign functions are now also heap allocated,
+          and scheme_define is used to define everything.
+     Version 1.20
+          Tracing has been added. The toplevel loop has been slightly
+	  rearranged. Backquote reading for vector templates has been
+	  sanitized. Symbol interning is now correct. Arithmetic functions
+	  have been corrected. APPLY, MAP, FOR-EACH, numeric comparison
+	  functions fixed. String reader/writer understands \xAA notation.
+     Version 1.19
+          Carriage Return now delimits identifiers. DOS-formatted Scheme files
+          can be used by Unix. Random number generator added to library.
+          Fixed some glitches of the new type-checking scheme. Fixed erroneous
+          (append '() 'a) behavior. Will continue with r4rstest.scm to
+          fix errors.
+     Version 1.18
+          The FFI has been extended. USE_VERBOSE_GC has gone. Anyone wanting
+          the same functionality can put (gcverbose #t) in init.scm.
+          print-width was removed, along with three corresponding op-codes.
+     	  Extended character constants with ASCII names were added.
+          mk_counted_string paves the way for full support of binary strings.
+          As much as possible of the type-checking chores were delegated
+          to the inner loop, thus reducing the code size to less than 4200 loc!
+     Version 1.17
+          Dynamically-loaded extensions are more fully integrated.
+          TinyScheme is now distributed under the BSD open-source license.
+     Version 1.16
+          Dynamically-loaded extensions introduced (USE_DL).
+          Santeri Paavolainen found a race condition: When a cons is executed,
+          and each of the two arguments is a constructing function,  GC could
+          happen before all arguments are evaluated and cons() is called, and
+          the evaluated arguments would all be reclaimed!
+          Fortunately, such a case was rare in the code, although it is
+          a pitfall in new code and code in foreign functions. Currently, only
+          one such case remains, when COLON_HOOK is defined.
+     Version 1.15
+          David Gould also contributed some changes that speed up operation.
+          Kirk Zurell fixed HASPROP.
+          The Garbage Collection didn't collect all the garbage...fixed.
+     Version 1.14
+          Unfortunately, after Andre fixed the GC it became obvious that the
+          algorithm was too slow... Fortunately, David Gould found a way to
+          speed it up.
+     Version 1.13
+          Silly bug involving division by zero resolved by Roland Kaufman.
+          Macintoch support from Shmulik Regev.
+          Float parser bug fixed by Alexander Shendi.
+          GC bug from Andru Luvisi.
+     Version 1.12
+          Cis* incorrectly called isalpha() instead of isascii()
+          Added USE_CHAR_CLASSIFIERS, USE_STRING_PORTS.
+     Version 1.11
+          BSDI defines isnumber... changed all similar functions to is_*
+          EXPT now has correct definition. Added FLOOR,CEILING,TRUNCATE
+          and ROUND, courtesy of Bengt Kleberg. Preprocessor symbols now
+          have values 1 or 0, and can be set as compiler defines (proposed
+          by Andy Ganor *months* ago). 'prompt' and 'InitFile' can now be
+          defined during compilation, too.
+     Version 1.10
+          Another bug when file ends with comment!
+          Added DEFINE-MACRO in init.scm, courtesy of Andy Gaynor.
+     Version 1.09
+          Removed bug when READ met EOF. lcm.
+     Version 1.08
+          quotient,remainder and modulo. gcd.
+     Version 1.07
+          '=>' in cond now exists
+          list? now checks for circularity
+          some reader bugs removed
+          Reader is more consistent wrt vectors
+          Quote and Quasiquote work with vectors
+     Version 1.06
+          #! is now skipped
+          generic-assoc bug removed
+          strings are now managed differently, hack.txt is removed
+          various delicate points fixed
+     Version 1.05
+          Support for scripts, *args*, "-1" option.
+          Various R5RS procedures.
+          *sharp-hook*
+          Handles unmatched parentheses.
+          New architecture for procedures.
+     Version 1.04
+          Added missing T_ATOM bits...
+          Added vectors
+          Free-list is sorted by address, since vectors need consecutive cells.
+          (quit <exitcode>) for use with scripts
+     Version 1.03 (26 Aug 1998):
+          Extended .h with useful functions for FFI
+          Library: with-input-* etc.
+          Finished R5RS I/O, added string ports.
+     Version 1.02 (25 Aug 1998):
+          First part of R5RS I/O.
+	
\ No newline at end of file
Index: payloads/tinyscheme/COPYING
===================================================================
--- payloads/tinyscheme/COPYING	(revision 0)
+++ payloads/tinyscheme/COPYING	(revision 0)
@@ -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.
Index: payloads/tinyscheme/embed_file
===================================================================
--- payloads/tinyscheme/embed_file	(revision 0)
+++ payloads/tinyscheme/embed_file	(revision 0)
@@ -0,0 +1,40 @@
+#!/bin/bash
+
+
+while getopts ":o:" opt; do
+  case $opt in
+      o)
+	  OUTFILE=$OPTARG
+	  ;;
+      \?)
+	  echo "Invalid option: -$OPTARG" >&2
+	  ;;
+      :)
+	  echo "Option -$OPTARG requires an argument." >&2
+	  exit 1
+
+  esac
+done
+
+shift $((OPTIND-1))
+
+FILES=($*)
+
+NFILES=${#FILES[@]}
+printf "struct _EMBEDDED_FILE_\n" > $OUTFILE
+printf "{\n"  >> $OUTFILE
+printf "	char* name;\n"  >> $OUTFILE
+printf "	char* data;\n"  >> $OUTFILE
+printf "	unsigned int pos;\n"  >> $OUTFILE
+printf "};\n"  >> $OUTFILE
+
+printf "#define NFILES %d\n" "$NFILES" >> $OUTFILE
+printf "struct _EMBEDDED_FILE_ _files[NFILES]= {\n" >> $OUTFILE
+for ind in $(seq 0 $(( $NFILES - 1 ))); do
+    printf '{ .name="%s", .pos=0, .data=' "$(basename ${FILES[$ind]})" >> $OUTFILE
+    cat ${FILES[$ind]} | tr -d '\r' | while read line; do echo -n '"'; echo -n $line |sed 's/"/\\"/g'; echo '\n"'; done >> $OUTFILE
+    printf '},\n' >> $OUTFILE
+done
+printf "};\n" >> $OUTFILE
+
+exit 0
Index: payloads/tinyscheme/dynload.c
===================================================================
--- payloads/tinyscheme/dynload.c	(revision 0)
+++ payloads/tinyscheme/dynload.c	(revision 0)
@@ -0,0 +1,145 @@
+/* dynload.c Dynamic Loader for TinyScheme */
+/* Original Copyright (c) 1999 Alexander Shendi     */
+/* Modifications for NT and dl_* interface, scm_load_ext: D. Souflis */
+/* Refurbished by Stephen Gildea */
+
+#define _SCHEME_SOURCE
+#include "dynload.h"
+#include <string.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#ifndef MAXPATHLEN
+# define MAXPATHLEN 1024
+#endif
+
+static void make_filename(const char *name, char *filename); 
+static void make_init_fn(const char *name, char *init_fn); 
+
+#ifdef _WIN32
+# include <windows.h>
+#else
+typedef void *HMODULE;
+typedef void (*FARPROC)();
+#define SUN_DL
+#include <dlfcn.h>
+#endif
+
+#ifdef _WIN32
+
+#define PREFIX ""
+#define SUFFIX ".dll"
+
+ static void display_w32_error_msg(const char *additional_message) 
+ { 
+   LPVOID msg_buf; 
+ 
+   FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, 
+		 NULL, GetLastError(), 0, 
+		 (LPTSTR)&msg_buf, 0, NULL); 
+   fprintf(stderr, "scheme load-extension: %s: %s", additional_message, msg_buf); 
+   LocalFree(msg_buf); 
+ } 
+
+static HMODULE dl_attach(const char *module) {
+  HMODULE dll = LoadLibrary(module);
+  if (!dll) display_w32_error_msg(module); 
+  return dll; 
+}
+
+static FARPROC dl_proc(HMODULE mo, const char *proc) {
+  FARPROC procedure = GetProcAddress(mo,proc); 
+  if (!procedure) display_w32_error_msg(proc); 
+  return procedure; 
+}
+
+static void dl_detach(HMODULE mo) {
+ (void)FreeLibrary(mo);
+}
+
+#elif defined(SUN_DL)
+
+#include <dlfcn.h>
+
+#define PREFIX "lib"
+#define SUFFIX ".so"
+
+static HMODULE dl_attach(const char *module) {
+  HMODULE so=dlopen(module,RTLD_LAZY);
+  if(!so) {
+    fprintf(stderr, "Error loading scheme extension \"%s\": %s\n", module, dlerror()); 
+  }
+  return so;
+}
+
+static FARPROC dl_proc(HMODULE mo, const char *proc) {
+  const char *errmsg;
+  FARPROC fp=(FARPROC)dlsym(mo,proc);
+  if ((errmsg = dlerror()) == 0) {
+    return fp;
+  }
+  fprintf(stderr, "Error initializing scheme module \"%s\": %s\n", proc, errmsg);
+ return 0;
+}
+
+static void dl_detach(HMODULE mo) {
+ (void)dlclose(mo);
+}
+#endif
+
+pointer scm_load_ext(scheme *sc, pointer args)
+{
+   pointer first_arg;
+   pointer retval;
+   char filename[MAXPATHLEN], init_fn[MAXPATHLEN+6];
+   char *name;
+   HMODULE dll_handle;
+   void (*module_init)(scheme *sc);
+   
+   if ((args != sc->NIL) && is_string((first_arg = pair_car(args)))) {
+      name = string_value(first_arg);
+      make_filename(name,filename);     
+      make_init_fn(name,init_fn);     
+      dll_handle = dl_attach(filename);
+      if (dll_handle == 0) {
+         retval = sc -> F;
+      }
+      else {
+         module_init = (void(*)(scheme *))dl_proc(dll_handle, init_fn);
+         if (module_init != 0) {
+            (*module_init)(sc);
+            retval = sc -> T;
+         }
+         else {
+            retval = sc->F;
+         }
+      }
+   }
+   else {
+      retval = sc -> F;
+   }
+   
+  return(retval);
+}
+
+static void make_filename(const char *name, char *filename) {
+ strcpy(filename,name);
+ strcat(filename,SUFFIX);
+}         
+
+static void make_init_fn(const char *name, char *init_fn) {
+ const char *p=strrchr(name,'/');
+ if(p==0) {
+     p=name;
+ } else {
+     p++;
+ }
+ strcpy(init_fn,"init_");
+ strcat(init_fn,p);
+}
+
+
+
+
+
+
Index: payloads/tinyscheme/README.LIBPAYLOAD
===================================================================
--- payloads/tinyscheme/README.LIBPAYLOAD	(revision 0)
+++ payloads/tinyscheme/README.LIBPAYLOAD	(revision 0)
@@ -0,0 +1,21 @@
+Float/math support is disabled by default. You'll need a patched libpayload with math/float support to use these. See makefile to re-add this.
+
+Most of the changes are in:
+scheme.c: Added basic readline support for interactive use since it's available in libpayload. Also added a USE_FLOATS define to optionaly disable float support in tinyscheme since libpayload doesn't have the needed float/math functions (a patch to add these was submitted).
+embed_file: A script that reads some scheme files and creates a C file (toembed.c) with strings containing these scripts which is linked with the binary. tinyscheme's init.scm which contains additional constructs (optional but useful) is loaded this way.
+
+Other files you might want to check:
+coreboot/targets/emulation/qemu-x86/Config.lb --> payload configuration
+coreboot/payloads/libpayload/.config --> libpayload configuration
+tinyscheme.ldscript --> If you need to increase heap/stack size. libpayload's default of 16384 is not enough.
+
+To embed your own scripts:
+./embed_file -o toembed.c init.scm myscript1.scm myscript2.scm
+
+See main() in scheme.c to see how init.scm is loaded.
+
+
+If you use this for something cool/interesting, I'd be happy to hear about it!
+
+
+--- Sylvain Ageneau <sylvain_ageneau@yahoo.fr>
Index: payloads/tinyscheme/makefile
===================================================================
--- payloads/tinyscheme/makefile	(revision 0)
+++ payloads/tinyscheme/makefile	(revision 0)
@@ -0,0 +1,126 @@
+# Makefile for TinyScheme 
+# Time-stamp: <2002-06-24 14:13:27 gildea> 
+
+# Windows/2000 
+#CC = cl -nologo 
+#DEBUG= -W3 -Z7 -MD 
+#DL_FLAGS= 
+#SYS_LIBS= 
+#Osuf=obj 
+#SOsuf=dll 
+#LIBsuf=.lib
+#EXE_EXT=.exe 
+#LD = link -nologo 
+#LDFLAGS = -debug -map -dll -incremental:no 
+#LIBPREFIX = 
+#OUT = -out:$@ 
+#RM= -del
+#AR= echo
+
+# Unix, generally 
+# CC = gcc -fpic 
+# DEBUG=-g -Wall -Wno-char-subscripts -O 
+# Osuf=o 
+# SOsuf=so 
+# LIBsuf=a
+# EXE_EXT=
+# LIBPREFIX=lib
+# OUT = -o $@ 
+# RM= -rm -f
+# AR= ar crs
+
+# Linux 
+# LD = gcc 
+# LDFLAGS = -shared 
+# DEBUG=-g -Wno-char-subscripts -O
+# SYS_LIBS= -ldl
+# PLATFORM_FEATURES= -DSUN_DL=1
+
+# Cygwin
+# PLATFORM_FEATURES = -DUSE_STRLWR=0
+
+# Solaris 
+#SYS_LIBS= -ldl -lc 
+#Osuf=o 
+#SOsuf=so 
+#EXE_EXT= 
+#LD = ld 
+#LDFLAGS = -G -Bsymbolic -z text 
+#LIBPREFIX = lib 
+#OUT = -o $@ 
+
+#FEATURES = $(PLATFORM_FEATURES) -DUSE_DL=1 -DUSE_MATH=0 -DUSE_ASCII_NAMES=0 
+#OBJS = scheme.$(Osuf) dynload.$(Osuf) 
+
+# libpayload
+EXE_EXT=.elf
+Osuf=o
+LIBPAYLOAD_DIR := ../libpayload
+CC := $(LIBPAYLOAD_DIR)/bin/lpgcc
+LD := $(CC)
+AR= ar crs
+
+# DEBUG=-g -Wall -Wno-char-subscripts -O -DDEBUG=1
+# STRIP=true
+
+DEBUG=-Os -DDEBUG=0
+STRIP=strip
+
+CFLAGS= -std=c9x -I.
+LDFLAGS=-Wl,-T,tinyscheme.ldscript
+
+START=
+SYS_LIBS=
+PLATFORM_FEATURES=-DLIBPAYLOAD
+
+# Use this for minimal features
+#FEATURES = $(PLATFORM_FEATURES) -DUSE_NO_FEATURES -DUSE_READLINE
+
+# Use this if you use libpayload patched with math/float support
+#FEATURES = $(PLATFORM_FEATURES) -DUSE_READLINE -DUSE_MATH -DUSE_FLOATS -DUSE_ERROR_HOOK \
+#	 -DUSE_STRING_PORTS -DUSE_CHAR_CLASSIFIERS -DUSE_ASCII_NAMES -DUSE_TRACING -DUSE_COLON_HOOK \
+#	-DUSE_PLIST
+
+# Supported features with unpatched libpayload
+FEATURES = $(PLATFORM_FEATURES) -DUSE_READLINE -DUSE_MATH=0 -DUSE_FLOATS=0 -DUSE_ERROR_HOOK \
+	 -DUSE_STRING_PORTS -DUSE_CHAR_CLASSIFIERS -DUSE_ASCII_NAMES -DUSE_TRACING -DUSE_COLON_HOOK \
+	-DUSE_PLIST
+
+OBJS = scheme.$(Osuf) toembed.$(Osuf)
+
+LIBTARGET = $(LIBPREFIX)tinyscheme.$(SOsuf) 
+STATICLIBTARGET = $(LIBPREFIX)tinyscheme.$(LIBsuf)
+
+all: scheme$(EXE_EXT)
+
+%.$(Osuf): %.c 
+	$(CC) $(CFLAGS) -c $(DEBUG) $(FEATURES) $(DL_FLAGS) $< 
+
+toembed.c: init.scm
+	[ -x ./embed_file ] || chmod +x ./embed_file
+	./embed_file -o toembed.c init.scm
+
+$(LIBTARGET): $(OBJS) 
+	$(LD) $(LDFLAGS) $(OUT) $(OBJS) $(SYS_LIBS) 
+
+scheme$(EXE_EXT): $(OBJS) 
+	$(LD) $(LDFLAGS) -o $@ $(DEBUG) $(OBJS) $(SYS_LIBS) 
+	$(STRIP) $@
+
+# $(STATICLIBTARGET): $(OBJS)
+# 	$(AR) $@ $(OBJS)
+
+$(OBJS): scheme.h scheme-private.h opdefines.h
+dynload.$(Osuf): dynload.h 
+
+clean: 
+	$(RM) $(OBJS) $(LIBTARGET) $(STATICLIBTARGET) scheme$(EXE_EXT)
+	$(RM) tinyscheme.ilk tinyscheme.map tinyscheme.pdb tinyscheme.exp
+	$(RM) scheme.ilk scheme.map scheme.pdb scheme.lib scheme.exp
+	$(RM) *~
+
+TAGS_SRCS = scheme.h scheme.c dynload.h dynload.c
+
+tags: TAGS 
+TAGS: $(TAGS_SRCS) 
+	etags $(TAGS_SRCS) 
