1 files changed, 0 insertions, 8912 deletions

diff --git a/lang/tinyscheme/patches/patch-ab b/lang/tinyscheme/patches/patch-ab
deleted file mode 100644
index 82678b336b9..00000000000
--- a/lang/tinyscheme/patches/patch-ab
+++ /dev/null
@@ -1,8912 +0,0 @@
-$NetBSD: patch-ab,v 1.4 2005/03/24 16:30:45 agc Exp $
-
---- scheme.c.orig	2004-06-22 07:13:39.000000000 +0100
-+++ scheme.c	2005-03-24 16:23:49.000000000 +0000
-@@ -1,4450 +1,4457 @@
--/* T I N Y S C H E M E    1 . 3 5

-- *   Dimitrios Souflis (dsouflis@acm.org)

-- *   Based on MiniScheme (original credits follow)

-- * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)

-- * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp

-- * (MINISCM) This version has been modified by R.C. Secrist.

-- * (MINISCM)

-- * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.

-- * (MINISCM)

-- * (MINISCM) This is a revised and modified version by Akira KIDA.

-- * (MINISCM)	current version is 0.85k4 (15 May 1994)

-- *

-- */

--

--#define _SCHEME_SOURCE

--#include "scheme-private.h"

--#ifndef WIN32

--# include <unistd.h>

--#endif

--#if USE_DL

--# include "dynload.h"

--#endif

--#if USE_MATH

--# include <math.h>

--#endif

--#include <limits.h>

--#include <float.h>

--#include <ctype.h>

--

--#if USE_STRCASECMP

--#include <strings.h>

--#define stricmp strcasecmp

--#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.35"

--

--#include <string.h>

--#include <stdlib.h>

--#ifndef macintosh

--# 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 /* macintosh */

--

--#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

--# define InitFile "init.scm"

--#endif

--

--#ifndef FIRST_CELLSEGS

--# define FIRST_CELLSEGS 3

--#endif

--

--enum scheme_types {

--  T_STRING=1,

--  T_NUMBER=2,

--  T_SYMBOL=3,

--  T_PROC=4,

--  T_PAIR=5,

--  T_CLOSURE=6,

--  T_CONTINUATION=7,

--  T_FOREIGN=8,

--  T_CHARACTER=9,

--  T_PORT=10,

--  T_VECTOR=11,

--  T_MACRO=12,

--  T_PROMISE=13,

--  T_ENVIRONMENT=14,

--  T_LAST_SYSTEM_TYPE=14

--};

--

--/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */

--#define ADJ 32

--#define TYPE_BITS 5

--#define T_MASKTYPE      31    /* 0000000000011111 */

--#define T_SYNTAX      4096    /* 0001000000000000 */

--#define T_IMMUTABLE   8192    /* 0010000000000000 */

--#define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */

--#define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */

--#define MARK         32768    /* 1000000000000000 */

--#define UNMARK       32767    /* 0111111111111111 */

--

--

--static num num_add(num a, num b);

--static num num_mul(num a, num b);

--static num num_div(num a, num b);

--static num num_intdiv(num a, num b);

--static num num_sub(num a, num b);

--static num num_rem(num a, num b);

--static num num_mod(num a, num b);

--static int num_eq(num a, num b);

--static int num_gt(num a, num b);

--static int num_ge(num a, num b);

--static int num_lt(num a, num b);

--static int num_le(num a, num b);

--

--#if USE_MATH

--static double round_per_R5RS(double x);

--#endif

--static int is_zero_double(double x);

--

--static 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 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(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

--

--static int is_zero_double(double x) {

-- return x<DBL_MIN && x>-DBL_MIN;

--}

--

--static long binary_decode(const char *s) {

-- long x=0;

--

-- while(*s!=0 && (*s=='1' || *s=='0')) {

--     x<<=1;

--     x+=*s-'0';

--     s++;

-- }

--

-- return x;

--}

--

--/* allocate new cell segment */

--static int alloc_cellseg(scheme *sc, int n) {

--     pointer newp;

--     pointer last;

--     pointer p;

--     char *cp;

--     long i;

--     int k;

--     int adj=ADJ;

--

--     if(adj<sizeof(struct cell)) {

--       adj=sizeof(struct cell);

--     }

--

--     for (k = 0; k < n; k++) {

--          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)

--               return k;

--          cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);

--          if (cp == 0)

--               return k;

--	  i = ++sc->last_cell_seg ;

--	  sc->alloc_seg[i] = cp;

--	  /* adjust in TYPE_BITS-bit boundary */

--	  if(((unsigned)cp)%adj!=0) {

--	    cp=(char*)(adj*((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);

--}

--

--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);

--}

--

--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);

--}

--

--static pointer mk_number(scheme *sc, num n) {

-- if(n.is_fixnum) {

--     return mk_integer(sc,n.value.ivalue);

-- } else {

--     return mk_real(sc,n.value.rvalue);

-- }

--}

--

--/* allocate name to string area */

--static char *store_string(scheme *sc, int len_str, const char *str, char fill) {

--     char *q;

--     

--     q=(char*)sc->malloc(len_str+1);

--     if(q==0) {

--          sc->no_memory=1;

--          return sc->strbuff;

--     }

--     if(str!=0) {

--          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;

--     int has_dec_point=0;

--     int has_fp_exp = 0;

--

--#if USE_COLON_HOOK

--     if((p=strstr(q,"::"))!=0) {

--          *p=0;

--          return cons(sc, sc->COLON_HOOK,

--                          cons(sc,

--                              cons(sc,

--                                   sc->QUOTE,

--                                   cons(sc, mk_atom(sc,p+2), sc->NIL)),

--                              cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));

--     }

--#endif

--

--     p = q;

--     c = *p++; 

--     if ((c == '+') || (c == '-')) { 

--       c = *p++; 

--       if (c == '.') { 

--         has_dec_point=1; 

--	 c = *p++; 

--       } 

--       if (!isdigit(c)) { 

--	 return (mk_symbol(sc, strlwr(q))); 

--       } 

--     } else if (c == '.') { 

--       has_dec_point=1; 

--       c = *p++; 

--       if (!isdigit(c)) { 

--	 return (mk_symbol(sc, strlwr(q))); 

--       } 

--     } else if (!isdigit(c)) { 

--       return (mk_symbol(sc, strlwr(q))); 

--     }

--

--     for ( ; (c = *p) != 0; ++p) {

--          if (!isdigit(c)) {

--               if(c=='.') {

--                    if(!has_dec_point) {

--                         has_dec_point=1;

--                         continue;

--                    }

--               }

--               else if ((c == 'e') || (c == 'E')) {

--                       if(!has_fp_exp) {

--                          has_dec_point = 1; /* decimal point illegal

--                                                from now on */

--                          p++;

--                          if ((*p == '-') || (*p == '+') || isdigit(*p)) {

--                             continue;

--                          }

--                       }  

--               }    

--               return (mk_symbol(sc, strlwr(q)));

--          }

--     }

--     if(has_dec_point) {

--          return mk_real(sc,atof(q));

--     }

--     return (mk_integer(sc, atol(q)));

--}

--

--/* make constant */

--static pointer mk_sharp_const(scheme *sc, char *name) {

--     long    x;

--     char    tmp[256];

--

--     if (!strcmp(name, "t"))

--          return (sc->T);

--     else if (!strcmp(name, "f"))

--          return (sc->F);

--     else if (*name == 'o') {/* #o (octal) */

--          sprintf(tmp, "0%s", name+1);

--          sscanf(tmp, "%lo", &x);

--          return (mk_integer(sc, x));

--     } else if (*name == 'd') {    /* #d (decimal) */

--          sscanf(name+1, "%ld", &x);

--          return (mk_integer(sc, x));

--     } else if (*name == 'x') {    /* #x (hex) */

--          sprintf(tmp, "0x%s", name+1);

--          sscanf(tmp, "%lx", &x);

--          return (mk_integer(sc, x));

--     } else if (*name == 'b') {    /* #b (binary) */

--          x = binary_decode(name+1);

--          return (mk_integer(sc, x));

--     } else if (*name == '\\') { /* #\w (character) */

--          int c=0;

--          if(stricmp(name+1,"space")==0) {

--               c=' ';

--          } else if(stricmp(name+1,"newline")==0) {

--               c='\n';

--          } else if(stricmp(name+1,"return")==0) {

--               c='\r';

--          } else if(stricmp(name+1,"tab")==0) {

--               c='\t';

--     } else if(name[1]=='x' && name[2]!=0) {

--          int c1=0;

--          if(sscanf(name+2,"%x",&c1)==1 && 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;

--   if(file_interactive(sc)) {

--     putstr(sc,prompt);

--   }

-- }

--}

--

--static int file_interactive(scheme *sc) {

-- return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin

--     && sc->inport->_object._port->kind&port_file;

--}

--

--static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {

--  FILE *f;

--  char *rw;

--  port *pt;

--  if(prop==(port_input|port_output)) {

--    rw="a+";

--  } else if(prop==port_output) {

--    rw="w";

--  } else {

--    rw="r";

--  }

--  f=fopen(fn,rw);

--  if(f==0) {

--    return 0;

--  }

--  pt=port_rep_from_file(sc,f,prop);

--  pt->rep.stdio.closeit=1;

--  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(pt);

--  if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {

--    file_pop(sc);

--    if(sc->nesting!=0) {

--      return EOF;

--    }

--    goto again;

--  }

--  return c;

--}

--

--static int basic_inchar(port *pt) {

--  if(pt->kind&port_file) {

--    return fgetc(pt->rep.stdio.file);

--  } else {

--    if(*pt->rep.string.curr==0

--       || pt->rep.string.curr==pt->rep.string.past_the_end) {

--      return EOF;

--    } else {

--      return *pt->rep.string.curr++;

--    }

--  }

--}

--

--/* back character to input buffer */

--static void backchar(scheme *sc, int c) {

--  port *pt;

--  if(c==EOF) return;

--  pt=sc->inport->_object._port;

--  if(pt->kind&port_file) {

--    ungetc(c,pt->rep.stdio.file);

--  } else {

--    if(pt->rep.string.curr!=pt->rep.string.start) {

--      --pt->rep.string.curr;

--    }

--  }

--}

--

--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} 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 '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;

--    }

--  }

--}

--

--/* 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 ';':

--          return (TOK_COMMENT);

--     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 == '!') {

--               return TOK_COMMENT;

--          } 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 {

--               sprintf(p, "%.10g", rvalue_unchecked(l));

--          }

--     } 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,"#\\"); strcat(p,charnames[c]); 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);

--          if (file_interactive(sc)) {

--              putstr(sc,prompt);

--          }

--          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_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! */

--          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 (!is_zero_double(rvalue(car(x))))

--	   v=num_div(v,nvalue(car(x)));

--	 else {

--	   Error_0(sc,"/: division by zero");

--	 }

--       }

--       s_return(sc,mk_number(sc, v));

--

--     case OP_INTDIV:        /* quotient */

--          if(cdr(sc->args)==sc->NIL) {

--               x=sc->args;

--               v=num_one;

--          } else {

--               x = cdr(sc->args);

--               v = nvalue(car(sc->args));

--          }

--          for (; x != sc->NIL; x = cdr(x)) {

--               if (ivalue(car(x)) != 0)

--                    v=num_intdiv(v,nvalue(car(x)));

--               else {

--                    Error_0(sc,"quotient: division by zero");

--               }

--          }

--          s_return(sc,mk_number(sc, v));

--

--     case OP_REM:        /* remainder */

--          v = nvalue(car(sc->args));

--          if (ivalue(cadr(sc->args)) != 0)

--               v=num_rem(v,nvalue(cadr(sc->args)));

--          else {

--               Error_0(sc,"remainder: division by zero");

--          }

--          s_return(sc,mk_number(sc, v));

--

--     case OP_MOD:        /* modulo */

--          v = nvalue(car(sc->args));

--          if (ivalue(cadr(sc->args)) != 0)

--               v=num_mod(v,nvalue(cadr(sc->args)));

--          else {

--               Error_0(sc,"modulo: division by zero");

--          }

--          s_return(sc,mk_number(sc, v));

--

--     case OP_CAR:        /* car */

--       s_return(sc,caar(sc->args));

--

--     case OP_CDR:        /* cdr */

--       s_return(sc,cdar(sc->args));

--

--     case OP_CONS:       /* cons */

--          cdr(sc->args) = cadr(sc->args);

--          s_return(sc,sc->args);

--

--     case OP_SETCAR:     /* set-car! */

--       if(!is_immutable(car(sc->args))) {

--	 caar(sc->args) = cadr(sc->args);

--	 s_return(sc,car(sc->args));

--       } else {

--	 Error_0(sc,"set-car!: unable to alter immutable pair");

--       }

--

--     case OP_SETCDR:     /* set-cdr! */

--       if(!is_immutable(car(sc->args))) {

--	 cdar(sc->args) = cadr(sc->args);

--	 s_return(sc,car(sc->args));

--       } else {

--	 Error_0(sc,"set-cdr!: unable to alter immutable pair");

--       }

--

--     case OP_CHAR2INT: { /* char->integer */

--          char c;

--          c=(char)ivalue(car(sc->args));

--          s_return(sc,mk_integer(sc,(unsigned char)c));

--     }

--

--     case OP_INT2CHAR: { /* integer->char */

--          unsigned char c;

--          c=(unsigned char)ivalue(car(sc->args));

--          s_return(sc,mk_character(sc,(char)c));

--     }

--

--     case OP_CHARUPCASE: {

--          unsigned char c;

--          c=(unsigned char)ivalue(car(sc->args));

--          c=toupper(c);

--          s_return(sc,mk_character(sc,(char)c));

--     }

--

--     case OP_CHARDNCASE: {

--          unsigned char c;

--          c=(unsigned char)ivalue(car(sc->args));

--          c=tolower(c);

--          s_return(sc,mk_character(sc,(char)c));

--     }

--

--     case OP_STR2SYM:  /* string->symbol */

--          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));

--

--     case OP_STR2ATOM: /* string->atom */ {

--       char *s=strvalue(car(sc->args));

--       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);

--               }

--          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);

--          if (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,

--  mk_integer,

--  mk_real,

--  mk_symbol,

--  gensym,

--  mk_string,

--  mk_counted_string,

--  mk_character,

--  mk_vector,

--  mk_foreign_func,

--  putstr,

--  putcharacter,

--

--  is_string,

--  string_value,

--  is_number,

--  nvalue,

--  ivalue,

--  rvalue,

--  is_integer,

--  is_real,

--  is_character,

--  charvalue,

--  is_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(fin==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

--

--#ifdef macintosh

--int main()

--{

--     extern MacTS_main(int argc, char **argv);

--     char**    argv;

--     int argc = ccommand(&argv);

--     MacTS_main(argc,argv);

--     return 0;

--}

--int MacTS_main(int argc, char **argv) {

--#else

--int main(int argc, char **argv) {

--#endif

--  scheme sc;

--  FILE *fin;

--  char *file_name=InitFile;

--  int retcode;

--  int isfile=1;

--  

--  if(argc==1) {

--    printf(banner);

--  }

--  if(argc==2 && strcmp(argv[1],"-?")==0) {

--    printf("Usage: %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++;

--  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);

--  if(argc==1) {

--    scheme_load_file(&sc,stdin);

--  }

--  retcode=sc.retcode;

--  scheme_deinit(&sc);

--  

--  return retcode;

--}

--

--#endif

-+/* T I N Y S C H E M E    1 . 3 5
-+ *   Dimitrios Souflis (dsouflis@acm.org)
-+ *   Based on MiniScheme (original credits follow)
-+ * (MINISCM)               coded by Atsushi Moriwaki (11/5/1989)
-+ * (MINISCM)           E-MAIL :  moriwaki@kurims.kurims.kyoto-u.ac.jp
-+ * (MINISCM) This version has been modified by R.C. Secrist.
-+ * (MINISCM)
-+ * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.
-+ * (MINISCM)
-+ * (MINISCM) This is a revised and modified version by Akira KIDA.
-+ * (MINISCM)	current version is 0.85k4 (15 May 1994)
-+ *
-+ */
-+
-+#define _SCHEME_SOURCE
-+#include "scheme-private.h"
-+#ifndef WIN32
-+# include <unistd.h>
-+#endif
-+#if USE_DL
-+# include "dynload.h"
-+#endif
-+#if USE_MATH
-+# include <math.h>
-+#endif
-+#include <limits.h>
-+#include <float.h>
-+#include <ctype.h>
-+
-+#if USE_STRCASECMP
-+#include <strings.h>
-+#define stricmp strcasecmp
-+#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.35"
-+
-+#include <string.h>
-+#include <stdlib.h>
-+#ifdef macintosh
-+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 /* macintosh */
-+
-+#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 TINYSCHEMEPREFIX
-+# define TINYSCHEMEPREFIX	""
-+#endif
-+
-+#ifndef TINYSCHEMEDIR
-+# define TINYSCHEMEDIR	""
-+#endif
-+
-+#ifndef InitFile
-+# define InitFile TINYSCHEMEPREFIX TINYSCHEMEDIR "init.scm"
-+#endif
-+  
-+
-+#ifndef FIRST_CELLSEGS
-+# define FIRST_CELLSEGS 3
-+#endif
-+
-+enum scheme_types {
-+  T_STRING=1,
-+  T_NUMBER=2,
-+  T_SYMBOL=3,
-+  T_PROC=4,
-+  T_PAIR=5,
-+  T_CLOSURE=6,
-+  T_CONTINUATION=7,
-+  T_FOREIGN=8,
-+  T_CHARACTER=9,
-+  T_PORT=10,
-+  T_VECTOR=11,
-+  T_MACRO=12,
-+  T_PROMISE=13,
-+  T_ENVIRONMENT=14,
-+  T_LAST_SYSTEM_TYPE=14
-+};
-+
-+/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */
-+#define ADJ 32
-+#define TYPE_BITS 5
-+#define T_MASKTYPE      31    /* 0000000000011111 */
-+#define T_SYNTAX      4096    /* 0001000000000000 */
-+#define T_IMMUTABLE   8192    /* 0010000000000000 */
-+#define T_ATOM       16384    /* 0100000000000000 */   /* only for gc */
-+#define CLRATOM      49151    /* 1011111111111111 */   /* only for gc */
-+#define MARK         32768    /* 1000000000000000 */
-+#define UNMARK       32767    /* 0111111111111111 */
-+
-+
-+static num num_add(num a, num b);
-+static num num_mul(num a, num b);
-+static num num_div(num a, num b);
-+static num num_intdiv(num a, num b);
-+static num num_sub(num a, num b);
-+static num num_rem(num a, num b);
-+static num num_mod(num a, num b);
-+static int num_eq(num a, num b);
-+static int num_gt(num a, num b);
-+static int num_ge(num a, num b);
-+static int num_lt(num a, num b);
-+static int num_le(num a, num b);
-+
-+#if USE_MATH
-+static double round_per_R5RS(double x);
-+#endif
-+static int is_zero_double(double x);
-+
-+static 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 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(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
-+
-+static int is_zero_double(double x) {
-+ return x<DBL_MIN && x>-DBL_MIN;
-+}
-+
-+static long binary_decode(const char *s) {
-+ long x=0;
-+
-+ while(*s!=0 && (*s=='1' || *s=='0')) {
-+     x<<=1;
-+     x+=*s-'0';
-+     s++;
-+ }
-+
-+ return x;
-+}
-+
-+/* allocate new cell segment */
-+static int alloc_cellseg(scheme *sc, int n) {
-+     pointer newp;
-+     pointer last;
-+     pointer p;
-+     char *cp;
-+     long i;
-+     int k;
-+     int adj=ADJ;
-+
-+     if(adj<sizeof(struct cell)) {
-+       adj=sizeof(struct cell);
-+     }
-+
-+     for (k = 0; k < n; k++) {
-+          if (sc->last_cell_seg >= CELL_NSEGMENT - 1)
-+               return k;
-+          cp = (char*) sc->malloc(CELL_SEGSIZE * sizeof(struct cell)+adj);
-+          if (cp == 0)
-+               return k;
-+	  i = ++sc->last_cell_seg ;
-+	  sc->alloc_seg[i] = cp;
-+	  /* adjust in TYPE_BITS-bit boundary */
-+	  if(((long)cp)%adj!=0) {
-+	    cp=(char*)(adj*((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);
-+}
-+
-+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);
-+}
-+
-+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);
-+}
-+
-+static pointer mk_number(scheme *sc, num n) {
-+ if(n.is_fixnum) {
-+     return mk_integer(sc,n.value.ivalue);
-+ } else {
-+     return mk_real(sc,n.value.rvalue);
-+ }
-+}
-+
-+/* allocate name to string area */
-+static char *store_string(scheme *sc, int len_str, const char *str, char fill) {
-+     char *q;
-+     
-+     q=(char*)sc->malloc(len_str+1);
-+     if(q==0) {
-+          sc->no_memory=1;
-+          return sc->strbuff;
-+     }
-+     if(str!=0) {
-+          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;
-+     int has_dec_point=0;
-+     int has_fp_exp = 0;
-+
-+#if USE_COLON_HOOK
-+     if((p=strstr(q,"::"))!=0) {
-+          *p=0;
-+          return cons(sc, sc->COLON_HOOK,
-+                          cons(sc,
-+                              cons(sc,
-+                                   sc->QUOTE,
-+                                   cons(sc, mk_atom(sc,p+2), sc->NIL)),
-+                              cons(sc, mk_symbol(sc,strlwr(q)), sc->NIL)));
-+     }
-+#endif
-+
-+     p = q;
-+     c = *p++; 
-+     if ((c == '+') || (c == '-')) { 
-+       c = *p++; 
-+       if (c == '.') { 
-+         has_dec_point=1; 
-+	 c = *p++; 
-+       } 
-+       if (!isdigit(c)) { 
-+	 return (mk_symbol(sc, strlwr(q))); 
-+       } 
-+     } else if (c == '.') { 
-+       has_dec_point=1; 
-+       c = *p++; 
-+       if (!isdigit(c)) { 
-+	 return (mk_symbol(sc, strlwr(q))); 
-+       } 
-+     } else if (!isdigit(c)) { 
-+       return (mk_symbol(sc, strlwr(q))); 
-+     }
-+
-+     for ( ; (c = *p) != 0; ++p) {
-+          if (!isdigit(c)) {
-+               if(c=='.') {
-+                    if(!has_dec_point) {
-+                         has_dec_point=1;
-+                         continue;
-+                    }
-+               }
-+               else if ((c == 'e') || (c == 'E')) {
-+                       if(!has_fp_exp) {
-+                          has_dec_point = 1; /* decimal point illegal
-+                                                from now on */
-+                          p++;
-+                          if ((*p == '-') || (*p == '+') || isdigit(*p)) {
-+                             continue;
-+                          }
-+                       }  
-+               }    
-+               return (mk_symbol(sc, strlwr(q)));
-+          }
-+     }
-+     if(has_dec_point) {
-+          return mk_real(sc,atof(q));
-+     }
-+     return (mk_integer(sc, atol(q)));
-+}
-+
-+/* make constant */
-+static pointer mk_sharp_const(scheme *sc, char *name) {
-+     long    x;
-+     char    tmp[256];
-+
-+     if (!strcmp(name, "t"))
-+          return (sc->T);
-+     else if (!strcmp(name, "f"))
-+          return (sc->F);
-+     else if (*name == 'o') {/* #o (octal) */
-+          sprintf(tmp, "0%s", name+1);
-+          sscanf(tmp, "%lo", &x);
-+          return (mk_integer(sc, x));
-+     } else if (*name == 'd') {    /* #d (decimal) */
-+          sscanf(name+1, "%ld", &x);
-+          return (mk_integer(sc, x));
-+     } else if (*name == 'x') {    /* #x (hex) */
-+          sprintf(tmp, "0x%s", name+1);
-+          sscanf(tmp, "%lx", &x);
-+          return (mk_integer(sc, x));
-+     } else if (*name == 'b') {    /* #b (binary) */
-+          x = binary_decode(name+1);
-+          return (mk_integer(sc, x));
-+     } else if (*name == '\\') { /* #\w (character) */
-+          int c=0;
-+          if(stricmp(name+1,"space")==0) {
-+               c=' ';
-+          } else if(stricmp(name+1,"newline")==0) {
-+               c='\n';
-+          } else if(stricmp(name+1,"return")==0) {
-+               c='\r';
-+          } else if(stricmp(name+1,"tab")==0) {
-+               c='\t';
-+     } else if(name[1]=='x' && name[2]!=0) {
-+          int c1=0;
-+          if(sscanf(name+2,"%x",&c1)==1 && 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;
-+   if(file_interactive(sc)) {
-+     putstr(sc,prompt);
-+   }
-+ }
-+}
-+
-+static int file_interactive(scheme *sc) {
-+ return sc->file_i==0 && sc->load_stack[0].rep.stdio.file==stdin
-+     && sc->inport->_object._port->kind&port_file;
-+}
-+
-+static port *port_rep_from_filename(scheme *sc, const char *fn, int prop) {
-+  FILE *f;
-+  char *rw;
-+  port *pt;
-+  if(prop==(port_input|port_output)) {
-+    rw="a+";
-+  } else if(prop==port_output) {
-+    rw="w";
-+  } else {
-+    rw="r";
-+  }
-+  f=fopen(fn,rw);
-+  if(f==0) {
-+    return 0;
-+  }
-+  pt=port_rep_from_file(sc,f,prop);
-+  pt->rep.stdio.closeit=1;
-+  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(pt);
-+  if(c==EOF && sc->inport==sc->loadport && sc->file_i!=0) {
-+    file_pop(sc);
-+    if(sc->nesting!=0) {
-+      return EOF;
-+    }
-+    goto again;
-+  }
-+  return c;
-+}
-+
-+static int basic_inchar(port *pt) {
-+  if(pt->kind&port_file) {
-+    return fgetc(pt->rep.stdio.file);
-+  } else {
-+    if(*pt->rep.string.curr==0
-+       || pt->rep.string.curr==pt->rep.string.past_the_end) {
-+      return EOF;
-+    } else {
-+      return *pt->rep.string.curr++;
-+    }
-+  }
-+}
-+
-+/* back character to input buffer */
-+static void backchar(scheme *sc, int c) {
-+  port *pt;
-+  if(c==EOF) return;
-+  pt=sc->inport->_object._port;
-+  if(pt->kind&port_file) {
-+    ungetc(c,pt->rep.stdio.file);
-+  } else {
-+    if(pt->rep.string.curr!=pt->rep.string.start) {
-+      --pt->rep.string.curr;
-+    }
-+  }
-+}
-+
-+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} 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 '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;
-+    }
-+  }
-+}
-+
-+/* 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 ';':
-+          return (TOK_COMMENT);
-+     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 == '!') {
-+               return TOK_COMMENT;
-+          } 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 {
-+               sprintf(p, "%.10g", rvalue_unchecked(l));
-+          }
-+     } 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,"#\\"); strcat(p,charnames[c]); 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) 
-+{ 
-+  long 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) 
-+{ 
-+  long 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) 
-+{ 
-+  long 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);
-+          if (file_interactive(sc)) {
-+              putstr(sc,prompt);
-+          }
-+          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_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! */
-+          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 (!is_zero_double(rvalue(car(x))))
-+	   v=num_div(v,nvalue(car(x)));
-+	 else {
-+	   Error_0(sc,"/: division by zero");
-+	 }
-+       }
-+       s_return(sc,mk_number(sc, v));
-+
-+     case OP_INTDIV:        /* quotient */
-+          if(cdr(sc->args)==sc->NIL) {
-+               x=sc->args;
-+               v=num_one;
-+          } else {
-+               x = cdr(sc->args);
-+               v = nvalue(car(sc->args));
-+          }
-+          for (; x != sc->NIL; x = cdr(x)) {
-+               if (ivalue(car(x)) != 0)
-+                    v=num_intdiv(v,nvalue(car(x)));
-+               else {
-+                    Error_0(sc,"quotient: division by zero");
-+               }
-+          }
-+          s_return(sc,mk_number(sc, v));
-+
-+     case OP_REM:        /* remainder */
-+          v = nvalue(car(sc->args));
-+          if (ivalue(cadr(sc->args)) != 0)
-+               v=num_rem(v,nvalue(cadr(sc->args)));
-+          else {
-+               Error_0(sc,"remainder: division by zero");
-+          }
-+          s_return(sc,mk_number(sc, v));
-+
-+     case OP_MOD:        /* modulo */
-+          v = nvalue(car(sc->args));
-+          if (ivalue(cadr(sc->args)) != 0)
-+               v=num_mod(v,nvalue(cadr(sc->args)));
-+          else {
-+               Error_0(sc,"modulo: division by zero");
-+          }
-+          s_return(sc,mk_number(sc, v));
-+
-+     case OP_CAR:        /* car */
-+       s_return(sc,caar(sc->args));
-+
-+     case OP_CDR:        /* cdr */
-+       s_return(sc,cdar(sc->args));
-+
-+     case OP_CONS:       /* cons */
-+          cdr(sc->args) = cadr(sc->args);
-+          s_return(sc,sc->args);
-+
-+     case OP_SETCAR:     /* set-car! */
-+       if(!is_immutable(car(sc->args))) {
-+	 caar(sc->args) = cadr(sc->args);
-+	 s_return(sc,car(sc->args));
-+       } else {
-+	 Error_0(sc,"set-car!: unable to alter immutable pair");
-+       }
-+
-+     case OP_SETCDR:     /* set-cdr! */
-+       if(!is_immutable(car(sc->args))) {
-+	 cdar(sc->args) = cadr(sc->args);
-+	 s_return(sc,car(sc->args));
-+       } else {
-+	 Error_0(sc,"set-cdr!: unable to alter immutable pair");
-+       }
-+
-+     case OP_CHAR2INT: { /* char->integer */
-+          char c;
-+          c=(char)ivalue(car(sc->args));
-+          s_return(sc,mk_integer(sc,(unsigned char)c));
-+     }
-+
-+     case OP_INT2CHAR: { /* integer->char */
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_CHARUPCASE: {
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          c=toupper(c);
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_CHARDNCASE: {
-+          unsigned char c;
-+          c=(unsigned char)ivalue(car(sc->args));
-+          c=tolower(c);
-+          s_return(sc,mk_character(sc,(char)c));
-+     }
-+
-+     case OP_STR2SYM:  /* string->symbol */
-+          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));
-+
-+     case OP_STR2ATOM: /* string->atom */ {
-+       char *s=strvalue(car(sc->args));
-+       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);
-+               }
-+          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);
-+          if (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,
-+  mk_integer,
-+  mk_real,
-+  mk_symbol,
-+  gensym,
-+  mk_string,
-+  mk_counted_string,
-+  mk_character,
-+  mk_vector,
-+  mk_foreign_func,
-+  putstr,
-+  putcharacter,
-+
-+  is_string,
-+  string_value,
-+  is_number,
-+  nvalue,
-+  ivalue,
-+  rvalue,
-+  is_integer,
-+  is_real,
-+  is_character,
-+  charvalue,
-+  is_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(fin==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
-+
-+#ifdef macintosh
-+int main()
-+{
-+     extern MacTS_main(int argc, char **argv);
-+     char**    argv;
-+     int argc = ccommand(&argv);
-+     MacTS_main(argc,argv);
-+     return 0;
-+}
-+int MacTS_main(int argc, char **argv) {
-+#else
-+int main(int argc, char **argv) {
-+#endif
-+  scheme sc;
-+  FILE *fin;
-+  char *file_name=InitFile;
-+  int retcode;
-+  int isfile=1;
-+  
-+  if(argc==1) {
-+    printf(banner);
-+  }
-+  if(argc==2 && strcmp(argv[1],"-?")==0) {
-+    printf("Usage: %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++;
-+  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);
-+  if(argc==1) {
-+    scheme_load_file(&sc,stdin);
-+  }
-+  retcode=sc.retcode;
-+  scheme_deinit(&sc);
-+  
-+  return retcode;
-+}
-+
-+#endif