Lax.c

/* Lax.c */

#define _Lax_SOURCE
#include "Lax-cell.h"
#if USE_MATH
# include <math.h>
#endif

#include <limits.h>
#include <float.h>
#include <ctype.h>
#include <stdlib.h>
#include "linenoise.h"
#include <sys/stat.h>
#include <sys/types.h>
#include <fcntl.h>

#include "ili.h"
#if USE_STRCASECMP
#include <strings.h>
#include <unistd.h>
# ifndef __APPLE__
#  define stricmp strcasecmp
# endif
#endif

#define INTERFACE

#define TOK_EOF     (-1)
#define TOK_LPAREN  0
#define TOK_RPAREN  1
#define TOK_DOT     2
#define TOK_ATOM    3
#define TOK_QUOTE   4
#define TOK_COMMENT 5
#define TOK_DQUOTE  6
#define TOK_BQUOTE  7
#define TOK_COMMA   8
#define TOK_ATMARK  9
#define TOK_SHARP   10
#define TOK_SHARP_CONST 11
#define TOK_VEC     12

#define BACKQUOTE '`'
#define DELIMITERS  "[]\"\f\t\v\n\r ;"

#define banner "Lax 6.0 (6.0.7) Lax Inc. (C) Anthony Lubmansky, Mavox-ID, N467, NeedYOU7"

#include <string.h>
#include <stdlib.h>

#ifdef __APPLE__
static int stricmp(const char *s1, const char *s2)
{
  unsigned char c1, c2;
  do {
    c1 = tolower(*s1);
    c2 = tolower(*s2);
    if (c1 < c2)
      return -1;
    else if (c1 > c2)
      return 1;
    s1++, s2++;
  } while (c1 != 0);
  return 0;
}
#endif

#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 "Lax> "
#endif

#ifndef InitFile
# define InitFile "init.lx"
#endif

#ifndef FIRST_CELLSEGS
# define FIRST_CELLSEGS 3
#endif

enum Lax_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
};

#define ADJ 32
#define TYPE_BITS 5
#define T_MASKTYPE      31
#define T_SYNTAX      4096
#define T_IMMUTABLE   8192
#define T_ATOM       16384
#define CLRATOM      49151
#define MARK         32768
#define UNMARK       32767


static num num_add(num a, num b);
static num num_mul(num a, num b);
static num num_div(num a, num b);
static num num_intdiv(num a, num b);
static num num_sub(num a, num b);
static num num_rem(num a, num b);
static num num_mod(num a, num b);
static int num_eq(num a, num b);
static int num_gt(num a, num b);
static int num_ge(num a, num b);
static int num_lt(num a, num b);
static int num_le(num a, num b);

#if USE_MATH
static double round_per_R5RS(double x);
#endif
static int is_zero_double(double x);
static INLINE int num_is_integer(pointer p) {
  return ((p)->_object._number.is_fixnum);
}

static num num_zero;
static num num_one;

#define typeflag(p)      ((p)->_flag)
#define type(p)          (typeflag(p)&T_MASKTYPE)

INTERFACE INLINE int is_string(pointer p)     { return (type(p)==T_STRING); }
#define strvalue(p)      ((p)->_object._string._svalue)
#define strlength(p)        ((p)->_object._string._length)

INTERFACE static int is_list(Lax *sc, pointer p);
INTERFACE INLINE int is_vector(pointer p)    { return (type(p)==T_VECTOR); }
INTERFACE static void fill_vector(pointer vec, pointer obj);
INTERFACE static pointer vector_elem(pointer vec, int ielem);
INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a);
INTERFACE INLINE int is_number(pointer p)    { return (type(p)==T_NUMBER); }
INTERFACE INLINE int is_integer(pointer p) {
  if (!is_number(p))
      return 0;
  if (num_is_integer(p) || (double)ivalue(p) == rvalue(p))
      return 1;
  return 0;
}

INTERFACE INLINE int is_real(pointer p) {
  return is_number(p) && (!(p)->_object._number.is_fixnum);
}

INTERFACE INLINE int is_character(pointer p) { return (type(p)==T_CHARACTER); }
INTERFACE INLINE char *string_value(pointer p) { return strvalue(p); }
INLINE num nvalue(pointer p)       { return ((p)->_object._number); }
INTERFACE long ivalue(pointer p)      { return (num_is_integer(p)?(p)->_object._number.value.ivalue:(long)(p)->_object._number.value.rvalue); }
INTERFACE double rvalue(pointer p)    { return (!num_is_integer(p)?(p)->_object._number.value.rvalue:(double)(p)->_object._number.value.ivalue); }
#define ivalue_unchecked(p)       ((p)->_object._number.value.ivalue)
#define rvalue_unchecked(p)       ((p)->_object._number.value.rvalue)
#define set_num_integer(p)   (p)->_object._number.is_fixnum=1;
#define set_num_real(p)      (p)->_object._number.is_fixnum=0;
INTERFACE  long charvalue(pointer p)  { return ivalue_unchecked(p); }

INTERFACE INLINE int is_port(pointer p)     { return (type(p)==T_PORT); }
INTERFACE INLINE int is_inport(pointer p)  { return is_port(p) && p->_object._port->kind & port_input; }
INTERFACE INLINE int is_outport(pointer p) { return is_port(p) && p->_object._port->kind & port_output; }

INTERFACE INLINE int is_pair(pointer p)     { return (type(p)==T_PAIR); }
#define car(p)           ((p)->_object._cons._car)
#define cdr(p)           ((p)->_object._cons._cdr)
INTERFACE pointer pair_car(pointer p)   { return car(p); }
INTERFACE pointer pair_cdr(pointer p)   { return cdr(p); }
INTERFACE pointer set_car(pointer p, pointer q) { return car(p)=q; }
INTERFACE pointer set_cdr(pointer p, pointer q) { return cdr(p)=q; }

INTERFACE INLINE int is_symbol(pointer p)   { return (type(p)==T_SYMBOL); }
INTERFACE INLINE char *symname(pointer p)   { return strvalue(car(p)); }
#if USE_PLIST
Lax_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)

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); }
INTERFACE INLINE void setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }

#define caar(p)          car(car(p))
#define cadr(p)          car(cdr(p))
#define cdar(p)          cdr(car(p))
#define cddr(p)          cdr(cdr(p))
#define cadar(p)         car(cdr(car(p)))
#define caddr(p)         car(cdr(cdr(p)))
#define cdaar(p)         cdr(car(car(p)))
#define cadaar(p)        car(cdr(car(car(p))))
#define cadddr(p)        car(cdr(cdr(cdr(p))))
#define cddddr(p)        cdr(cdr(cdr(cdr(p))))

#if USE_CHAR_CLASSIFIERS
static INLINE int Cisalpha(int c) { return isascii(c) && isalpha(c); }
static INLINE int Cisdigit(int c) { return isascii(c) && isdigit(c); }
static INLINE int Cisspace(int c) { return isascii(c) && isspace(c); }
static INLINE int Cisupper(int c) { return isascii(c) && isupper(c); }
static INLINE int Cislower(int c) { return isascii(c) && islower(c); }
#endif

#if USE_ASCII_NAMES
static const char *charnames[32]={
 "nul",
 "soh",
 "stx",
 "etx",
 "eot",
 "enq",
 "ack",
 "bel",
 "bs",
 "ht",
 "lf",
 "vt",
 "ff",
 "cr",
 "so",
 "si",
 "dle",
 "dc1",
 "dc2",
 "dc3",
 "dc4",
 "nak",
 "syn",
 "etb",
 "can",
 "em",
 "sub",
 "esc",
 "fs",
 "gs",
 "rs",
 "us"
};

static int is_ascii_name(const char *name, int *pc) {
  int i;
  for(i=0; i<32; i++) {
     if(stricmp(name,charnames[i])==0) {
          *pc=i;
          return 1;
     }
  }
  if(stricmp(name,"del")==0) {
     *pc=127;
     return 1;
  }
  return 0;
}

#endif

static int file_push(Lax *sc, const char *fname);
static void file_pop(Lax *sc);
static int file_interactive(Lax *sc);
static INLINE int is_one_of(char *s, int c);
static int alloc_cellseg(Lax *sc, int n);
static long binary_decode(const char *s);
static INLINE pointer get_cell(Lax *sc, pointer a, pointer b);
static pointer _get_cell(Lax *sc, pointer a, pointer b);
static pointer reserve_cells(Lax *sc, int n);
static pointer get_consecutive_cells(Lax *sc, int n);
static pointer find_consecutive_cells(Lax *sc, int n);
static void finalize_cell(Lax *sc, pointer a);
static int count_consecutive_cells(pointer x, int needed);
static pointer find_slot_in_env(Lax *sc, pointer env, pointer sym, int all);
static pointer mk_number(Lax *sc, num n);
static char *store_string(Lax *sc, int len, const char *str, char fill);
static pointer mk_vector(Lax *sc, int len);
static pointer mk_atom(Lax *sc, char *q);
static pointer mk_sharp_const(Lax *sc, char *name);
static pointer mk_port(Lax *sc, port *p);
static pointer port_from_filename(Lax *sc, const char *fn, int prop);
static pointer port_from_file(Lax *sc, FILE *, int prop);
static pointer port_from_string(Lax *sc, char *start, char *past_the_end, int prop);
static port *port_rep_from_filename(Lax *sc, const char *fn, int prop);
static port *port_rep_from_file(Lax *sc, FILE *, int prop);
static port *port_rep_from_string(Lax *sc, char *start, char *past_the_end, int prop);
static void port_close(Lax *sc, pointer p, int flag);
static void mark(pointer a);
static void gc(Lax *sc, pointer a, pointer b);
static int basic_inchar(port *pt);
static int inchar(Lax *sc);
static void backchar(Lax *sc, int c);
static char   *readstr_upto(Lax *sc, char *delim);
static pointer readstrexp(Lax *sc);
static INLINE int skipspace(Lax *sc);
static int token(Lax *sc);
static void printslashstring(Lax *sc, char *s, int len);
static void atom2str(Lax *sc, pointer l, int f, char **pp, int *plen);
static void printatom(Lax *sc, pointer l, int f);
static pointer mk_proc(Lax *sc, enum Lax_opcodes op);
static pointer mk_closure(Lax *sc, pointer c, pointer e);
static pointer mk_continuation(Lax *sc, pointer d);
static pointer reverse(Lax *sc, pointer a);
static pointer reverse_in_place(Lax *sc, pointer term, pointer list);
static pointer revappend(Lax *sc, pointer a, pointer b);
static void dump_stack_mark(Lax *);
static pointer opexe_0(Lax *sc, enum Lax_opcodes op);
static pointer opexe_1(Lax *sc, enum Lax_opcodes op);
static pointer opexe_2(Lax *sc, enum Lax_opcodes op);
static pointer opexe_3(Lax *sc, enum Lax_opcodes op);
static pointer opexe_4(Lax *sc, enum Lax_opcodes op);
static pointer opexe_5(Lax *sc, enum Lax_opcodes op);
static pointer opexe_6(Lax *sc, enum Lax_opcodes op);
static void Eval_Cycle(Lax *sc, enum Lax_opcodes op);
static void assign_syntax(Lax *sc, char *name);
static int syntaxnum(pointer p);
static void assign_proc(Lax *sc, enum Lax_opcodes, char *name);

void putcharacter(Lax *sc, int c); 

#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;
 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) {
    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
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) {
          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;
}

static int alloc_cellseg(Lax *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;
         if(((unsigned long)cp)%adj!=0) {
           cp=(char*)(adj*((unsigned long)cp/adj+1));
         }
         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;
         }
         if (sc->free_cell == sc->NIL || p < sc->free_cell) {
              cdr(last) = sc->free_cell;
              sc->free_cell = newp;
         } else {
               p = sc->free_cell;
               while (cdr(p) != sc->NIL && newp > cdr(p))
                    p = cdr(p);
               cdr(last) = cdr(p);
               cdr(p) = newp;
         }
     }
     return n;
}

static INLINE pointer get_cell_x(Lax *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);
}

static pointer _get_cell(Lax *sc, pointer a, pointer b) {
  pointer x;

  if(sc->no_memory) {
    return sc->sink;
  }

  if (sc->free_cell == sc->NIL) {
    const int min_to_be_recovered = sc->last_cell_seg*8;
    gc(sc,a, b);
    if (sc->fcells < min_to_be_recovered
        || sc->free_cell == sc->NIL) {
      if (!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 reserve_cells(Lax *sc, int n) {
    if(sc->no_memory) {
        return sc->NIL;
    }

    if (sc->fcells < n) {
        gc(sc, sc->NIL, sc->NIL);
        if (sc->fcells < n) {
            if (!alloc_cellseg(sc,1)) {
                sc->no_memory=1;
                return sc->NIL;
            }
        }
        if (sc->fcells < n) {
            sc->no_memory=1;
            return sc->NIL;
        }
    }
    return (sc->T);
}

static pointer get_consecutive_cells(Lax *sc, int n) {
  pointer x;

  if(sc->no_memory) { return sc->sink; }

  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  gc(sc, sc->NIL, sc->NIL);
  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  if (!alloc_cellseg(sc,1))
    {
      sc->no_memory=1;
      return sc->sink;
    }

  x=find_consecutive_cells(sc,n);
  if (x != sc->NIL) { return x; }

  sc->no_memory=1;
  return sc->sink;
}

static int count_consecutive_cells(pointer x, int needed) {
 int n=1;
 while(cdr(x)==x+1) {
     x=cdr(x);
     n++;
     if(n>needed) return n;
 }
 return n;
}

static pointer find_consecutive_cells(Lax *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;
}

static void push_recent_alloc(Lax *sc, pointer recent, pointer extra)
{
  pointer holder = get_cell_x(sc, recent, extra);
  typeflag(holder) = T_PAIR | T_IMMUTABLE;
  car(holder) = recent;
  cdr(holder) = car(sc->sink);
  car(sc->sink) = holder;
}


static pointer get_cell(Lax *sc, pointer a, pointer b)
{
  pointer cell   = get_cell_x(sc, a, b);
  typeflag(cell) = T_PAIR;
  car(cell) = a;
  cdr(cell) = b;
  push_recent_alloc(sc, cell, sc->NIL);
  return cell;
}

static pointer get_vector_object(Lax *sc, int len, pointer init)
{
  pointer cells = get_consecutive_cells(sc,len/2+len%2+1);
  if(sc->no_memory) { return sc->sink; }
  typeflag(cells) = (T_VECTOR | T_ATOM);
  ivalue_unchecked(cells)=len;
  set_num_integer(cells);
  fill_vector(cells,init);
  push_recent_alloc(sc, cells, sc->NIL);
  return cells;
}

static INLINE void ok_to_freely_gc(Lax *sc)
{
  car(sc->sink) = sc->NIL;
}


#if defined TSGRIND
static void check_cell_alloced(pointer p, int expect_alloced)
{
  if(typeflag(p) & !expect_alloced)
    {
      fprintf(stderr,"Cell is already allocated!\n");
    }
  if(!(typeflag(p)) & expect_alloced)
    {
      fprintf(stderr,"Cell is not allocated!\n");
    }

}
static void check_range_alloced(pointer p, int n, int expect_alloced)
{
  int i;
  for(i = 0;i<n;i++)
    { (void)check_cell_alloced(p+i,expect_alloced); }
}

#endif

pointer _cons(Lax *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);
}

#ifndef USE_OBJECT_LIST

static int hash_fn(const char *key, int table_size);

static pointer oblist_initial_value(Lax *sc)
{
  return mk_vector(sc, 461);
}

static pointer oblist_add_by_name(Lax *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(Lax *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));
    if(stricmp(name, s) == 0) {
      return car(x);
    }
  }
  return sc->NIL;
}

static pointer oblist_all_symbols(Lax *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(Lax *sc)
{
  return sc->NIL;
}

static INLINE pointer oblist_find_by_name(Lax *sc, const char *name)
{
     pointer x;
     char    *s;

     for (x = sc->oblist; x != sc->NIL; x = cdr(x)) {
        s = symname(car(x));
        if(stricmp(name, s) == 0) {
          return car(x);
        }
     }
     return sc->NIL;
}

static pointer oblist_add_by_name(Lax *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(Lax *sc)
{
  return sc->oblist;
}

#endif

static pointer mk_port(Lax *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(Lax *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(Lax *sc, int c) {
  pointer x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_CHARACTER | T_ATOM);
  ivalue_unchecked(x)= c;
  set_num_integer(x);
  return (x);
}

INTERFACE pointer mk_integer(Lax *sc, long num) {
  pointer x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_NUMBER | T_ATOM);
  ivalue_unchecked(x)= num;
  set_num_integer(x);
  return (x);
}

INTERFACE pointer mk_real(Lax *sc, double n) {
  pointer x = get_cell(sc,sc->NIL, sc->NIL);

  typeflag(x) = (T_NUMBER | T_ATOM);
  rvalue_unchecked(x)= n;
  set_num_real(x);
  return (x);
}

static pointer mk_number(Lax *sc, num n) {
 if(n.is_fixnum) {
     return mk_integer(sc,n.value.ivalue);
 } else {
     return mk_real(sc,n.value.rvalue);
 }
}

static char *store_string(Lax *sc, int len_str, const char *str, char fill) {
     char *q;

     q=(char*)sc->malloc(len_str+1);
     if(q==0) {
          sc->no_memory=1;
          return sc->strbuff;
     }
     if(str!=0) {
          snprintf(q, len_str+1, "%s", str);
     } else {
          memset(q, fill, len_str);
          q[len_str]=0;
     }
     return (q);
}

INTERFACE pointer mk_string(Lax *sc, const char *str) {
     return mk_counted_string(sc,str,strlen(str));
}

INTERFACE pointer mk_counted_string(Lax *sc, const char *str, int len) {
     pointer x = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(x) = (T_STRING | T_ATOM);
     strvalue(x) = store_string(sc,len,str,0);
     strlength(x) = len;
     return (x);
}

INTERFACE pointer mk_empty_string(Lax *sc, int len, char fill) {
     pointer x = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(x) = (T_STRING | T_ATOM);
     strvalue(x) = store_string(sc,len,0,fill);
     strlength(x) = len;
     return (x);
}

INTERFACE static pointer mk_vector(Lax *sc, int len)
{ return get_vector_object(sc,len,sc->NIL); }

INTERFACE static void fill_vector(pointer vec, pointer obj) {
     int i;
     int num=ivalue(vec)/2+ivalue(vec)%2;
     for(i=0; i<num; i++) {
          typeflag(vec+1+i) = T_PAIR;
          setimmutable(vec+1+i);
          car(vec+1+i)=obj;
          cdr(vec+1+i)=obj;
     }
}

INTERFACE static pointer vector_elem(pointer vec, int ielem) {
     int n=ielem/2;
     if(ielem%2==0) {
          return car(vec+1+n);
     } else {
          return cdr(vec+1+n);
     }
}

INTERFACE static pointer set_vector_elem(pointer vec, int ielem, pointer a) {
     int n=ielem/2;
     if(ielem%2==0) {
          return car(vec+1+n)=a;
     } else {
          return cdr(vec+1+n)=a;
     }
}

INTERFACE pointer mk_symbol(Lax *sc, const char *name) {
     pointer x;

     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(Lax *sc) {
     pointer x;
     char name[40];

     for(; sc->gensym_cnt<LONG_MAX; sc->gensym_cnt++) {
          snprintf(name,40,"gensym-%ld",sc->gensym_cnt);

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

static pointer mk_atom(Lax *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;
                          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)));
}

static pointer mk_sharp_const(Lax *sc, char *name) {
     long    x;
     char    tmp[STRBUFFSIZE];

     if (!strcmp(name, "t"))
          return (sc->T);
     else if (!strcmp(name, "f"))
          return (sc->F);
     else if (*name == 'o') {
          snprintf(tmp, STRBUFFSIZE, "0%s", name+1);
          sscanf(tmp, "%lo", (long unsigned *)&x);
          return (mk_integer(sc, x));
     } else if (*name == 'd') {
          sscanf(name+1, "%ld", (long int *)&x);
          return (mk_integer(sc, x));
     } else if (*name == 'x') {
          snprintf(tmp, STRBUFFSIZE, "0x%s", name+1);
          sscanf(tmp, "%lx", (long unsigned *)&x);
          return (mk_integer(sc, x));
     } else if (*name == 'b') {
          x = binary_decode(name+1);
          return (mk_integer(sc, x));
     } else if (*name == '\\') {
          int c=0;
          if(stricmp(name+1,"space")==0) {
               c=' ';
          } else if(stricmp(name+1,"newline")==0) {
               c='\n';
          } else if(stricmp(name+1,"return")==0) {
               c='\r';
          } else if(stricmp(name+1,"tab")==0) {
               c='\t';
     } else if(name[1]=='x' && name[2]!=0) {
          int c1=0;
          if(sscanf(name+2,"%x",(unsigned int *)&c1)==1 && c1 < UCHAR_MAX) {
               c=c1;
          } else {
               return sc->NIL;
     }
#if USE_ASCII_NAMES
          } else if(is_ascii_name(name+1,&c)) {
#endif
          } else if(name[2]==0) {
               c=name[1];
          } else {
               return sc->NIL;
          }
          return mk_character(sc,c);
     } else
          return (sc->NIL);
}

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++) {
               mark(p+1+i);
          }
     }
     if (is_atom(p))
          goto E6;
     q = car(p);
     if (q && !is_mark(q)) {
          setatom(p);
          car(p) = t;
          t = p;
          p = q;
          goto E2;
     }
E5:  q = cdr(p);
     if (q && !is_mark(q)) {
          cdr(p) = t;
          t = p;
          p = q;
          goto E2;
     }
E6:
     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;
     }
}

static void gc(Lax *sc, pointer a, pointer b) {
  pointer p;
  int i;

  if(sc->gc_verbose) {
    putstr(sc, "gc...");
  }

  mark(sc->oblist);
  mark(sc->global_env);

  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(car(sc->sink));
  mark(sc->c_nest);

  mark(a);
  mark(b);

  clrmark(sc->NIL);
  sc->fcells = 0;
  sc->free_cell = sc->NIL;
  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 {
        if (typeflag(p) != 0) {
          finalize_cell(sc, p);
          typeflag(p) = 0;
          car(p) = sc->NIL;
        }
        ++sc->fcells;
        cdr(p) = sc->free_cell;
        sc->free_cell = p;
      }
    }
  }

  if (sc->gc_verbose) {
    char msg[80];
    snprintf(msg,80,"done: %ld cells were recovered.\n", sc->fcells);
    putstr(sc,msg);
  }
}

static void finalize_cell(Lax *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);
  }
}

static int file_push(Lax *sc, const char *fname) {
  FILE *fin = NULL;

  if (sc->file_i == MAXFIL-1)
     return 0;
  fin=fopen(fname,"r");
  if(fin!=0) {
    sc->file_i++;
    sc->load_stack[sc->file_i].kind=port_file|port_input;
    sc->load_stack[sc->file_i].rep.stdio.file=fin;
    sc->load_stack[sc->file_i].rep.stdio.closeit=1;
    sc->nesting_stack[sc->file_i]=0;
    sc->loadport->_object._port=sc->load_stack+sc->file_i;

#if SHOW_ERROR_LINE
    sc->load_stack[sc->file_i].rep.stdio.curr_line = 0;
    if(fname)
      sc->load_stack[sc->file_i].rep.stdio.filename = store_string(sc, strlen(fname), fname, 0);
#endif
  }
  return fin!=0;
}

static void file_pop(Lax *sc) {
 if(sc->file_i != 0) {
   sc->nesting=sc->nesting_stack[sc->file_i];
   port_close(sc,sc->loadport,port_input);
   sc->file_i--;
   sc->loadport->_object._port=sc->load_stack+sc->file_i;
 }
}

static int file_interactive(Lax *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(Lax *sc, const char *fn, int prop) {
  FILE *f;
  char *rw;
  port *pt;
  if(prop==(port_input|port_output)) {
    rw="a+";
  } else if(prop==port_output) {
    rw="w";
  } else {
    rw="r";
  }
  f=fopen(fn,rw);
  if(f==0) {
    return 0;
  }
  pt=port_rep_from_file(sc,f,prop);
  pt->rep.stdio.closeit=1;

#if SHOW_ERROR_LINE
  if(fn)
    pt->rep.stdio.filename = store_string(sc, strlen(fn), fn, 0);

  pt->rep.stdio.curr_line = 0;
#endif
  return pt;
}

static pointer port_from_filename(Lax *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(Lax *sc, FILE *f, int prop)
{
    port *pt;

    pt = (port *)sc->malloc(sizeof *pt);
    if (pt == NULL) {
        return NULL;
    }
    pt->kind = port_file | prop;
    pt->rep.stdio.file = f;
    pt->rep.stdio.closeit = 0;
    return pt;
}

static pointer port_from_file(Lax *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(Lax *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(Lax *sc, char *start, char *past_the_end, int prop) {
  port *pt;
  pt=port_rep_from_string(sc,start,past_the_end,prop);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

#define BLOCK_SIZE 256

static port *port_rep_from_scratch(Lax *sc) {
  port *pt;
  char *start;
  pt=(port*)sc->malloc(sizeof(port));
  if(pt==0) {
    return 0;
  }
  start=sc->malloc(BLOCK_SIZE);
  if(start==0) {
    return 0;
  }
  memset(start,' ',BLOCK_SIZE-1);
  start[BLOCK_SIZE-1]='\0';
  pt->kind=port_string|port_output|port_srfi6;
  pt->rep.string.start=start;
  pt->rep.string.curr=start;
  pt->rep.string.past_the_end=start+BLOCK_SIZE-1;
  return pt;
}

static pointer port_from_scratch(Lax *sc) {
  port *pt;
  pt=port_rep_from_scratch(sc);
  if(pt==0) {
    return sc->NIL;
  }
  return mk_port(sc,pt);
}

static void port_close(Lax *sc, pointer p, int flag) {
  port *pt=p->_object._port;
  pt->kind&=~flag;
  if((pt->kind & (port_input|port_output))==0) {
    if(pt->kind&port_file) {

#if SHOW_ERROR_LINE
      pt->rep.stdio.curr_line = 0;

      if(pt->rep.stdio.filename)
        sc->free(pt->rep.stdio.filename);
#endif

      fclose(pt->rep.stdio.file);
    }
    pt->kind=port_free;
  }
}

static int inchar(Lax *sc) {
  int c;
  port *pt;

  pt = sc->inport->_object._port;
  if(pt->kind & port_saw_EOF)
    { return EOF; }
  c = basic_inchar(pt);
  if(c == EOF && sc->inport == sc->loadport) {
    pt->kind |= port_saw_EOF;

    return EOF;
  }
  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++;
    }
  }
}

static void backchar(Lax *sc, int c) {
  port *pt;
  if(c==EOF) return;
  pt=sc->inport->_object._port;
  if(pt->kind&port_file) {
    ungetc(c,pt->rep.stdio.file);
  } else {
    if(pt->rep.string.curr!=pt->rep.string.start) {
      --pt->rep.string.curr;
    }
  }
}

static int realloc_port_string(Lax *sc, port *p)
{
  char *start=p->rep.string.start;
  size_t new_size=p->rep.string.past_the_end-start+1+BLOCK_SIZE;
  char *str=sc->malloc(new_size);
  if(str) {
    memset(str,' ',new_size-1);
    str[new_size-1]='\0';
    strcpy(str,start);
    p->rep.string.start=str;
    p->rep.string.past_the_end=str+new_size-1;
    p->rep.string.curr-=start-str;
    sc->free(start);
    return 1;
  } else {
    return 0;
  }
}

INTERFACE void putstr(Lax *sc, const char *s) {
  port *pt=sc->outport->_object._port;
  if(pt->kind&port_file) {
    fputs(s,pt->rep.stdio.file);
  } else {
    for(;*s;s++) {
      if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
        *pt->rep.string.curr++=*s;
      } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
        *pt->rep.string.curr++=*s;
      }
    }
  }
}

static void putchars(Lax *sc, const char *s, int len) {
  port *pt=sc->outport->_object._port;
  if(pt->kind&port_file) {
    fwrite(s,1,len,pt->rep.stdio.file);
  } else {
    for(;len;len--) {
      if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
        *pt->rep.string.curr++=*s++;
      } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
        *pt->rep.string.curr++=*s++;
      }
    }
  }
}

INTERFACE void putcharacter(Lax *sc, int c) {
  port *pt=sc->outport->_object._port;
  if(pt->kind&port_file) {
    fputc(c,pt->rep.stdio.file);
  } else {
    if(pt->rep.string.curr!=pt->rep.string.past_the_end) {
      *pt->rep.string.curr++=c;
    } else if(pt->kind&port_srfi6&&realloc_port_string(sc,pt)) {
        *pt->rep.string.curr++=c;
    }
  }
}

static char *readstr_upto(Lax *sc, char *delim) {
  char *p = sc->strbuff;

  while ((p - sc->strbuff < sizeof(sc->strbuff)) &&
         !is_one_of(delim, (*p++ = inchar(sc))));

  if(p == sc->strbuff+2 && p[-2] == '\\') {
    *p=0;
  } else {
    backchar(sc,p[-1]);
    *--p = '\0';
  }
  return sc->strbuff;
}

static pointer readstrexp(Lax *sc) {
  char *p = sc->strbuff;
  int c;
  int c1=0;
  enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state=st_ok;

  for (;;) {
    c=inchar(sc);
    if(c == EOF || p-sc->strbuff > sizeof(sc->strbuff)-1) {
      return sc->F;
    }
    switch(state) {
        case st_ok:
            switch(c) {
                case '\\':
                    state=st_bsl;
                    break;
                case '"':
                    *p=0;
                    return mk_counted_string(sc,sc->strbuff,p-sc->strbuff);
                default:
                    *p++=c;
                    break;
            }
            break;
        case st_bsl:
            switch(c) {
                case '0':
                case '1':
                case '2':
                case '3':
                case '4':
                case '5':
                case '6':
                case '7':
                        state=st_oct1;
                        c1=c-'0';
                        break;
                case 'x':
                case 'X':
                    state=st_x1;
                    c1=0;
                    break;
                case 'n':
                    *p++='\n';
                    state=st_ok;
                    break;
                case 't':
                    *p++='\t';
                    state=st_ok;
                    break;
                case 'r':
                    *p++='\r';
                    state=st_ok;
                    break;
                case '"':
                    *p++='"';
                    state=st_ok;
                    break;
                default:
                    *p++=c;
                    state=st_ok;
                    break;
            }
            break;
        case st_x1:
        case st_x2:
            c=toupper(c);
            if(c>='0' && c<='F') {
                if(c<='9') {
                    c1=(c1<<4)+c-'0';
                } else {
                    c1=(c1<<4)+c-'A'+10;
                }
                if(state==st_x1) {
                    state=st_x2;
                } else {
                    *p++=c1;
                    state=st_ok;
                }
            } else {
                return sc->F;
            }
            break;
        case st_oct1:
        case st_oct2:
            if (c < '0' || c > '7')
            {
                   *p++=c1;
                   backchar(sc, c);
                   state=st_ok;
            }
            else
            {
                if (state==st_oct2 && c1 >= 32)
                    return sc->F;

                   c1=(c1<<3)+(c-'0');

                if (state == st_oct1)
                        state=st_oct2;
                else
                {
                        *p++=c1;
                        state=st_ok;
                   }
            }
            break;

    }
  }
}

static INLINE int is_one_of(char *s, int c) {
     if(c==EOF) return 1;
     while (*s)
          if (*s++ == c)
               return (1);
     return (0);
}

static INLINE int skipspace(Lax *sc) {
     int c = 0, curr_line = 0;

     do {
         c=inchar(sc);
#if SHOW_ERROR_LINE
         if(c=='\n')
           curr_line++;
#endif
     } while (isspace(c));

#if SHOW_ERROR_LINE
     if (sc->load_stack[sc->file_i].kind & port_file)
       sc->load_stack[sc->file_i].rep.stdio.curr_line += curr_line;
#endif

     if(c!=EOF) {
          backchar(sc,c);
      return 1;
     }
     else
       { return EOF; }
}

static int token(Lax *sc) {
     int c;
     c = skipspace(sc);
     if(c == EOF) { return (TOK_EOF); }
     switch (c=inchar(sc)) {
     case EOF:
          return (TOK_EOF);
     case '[':
          return (TOK_LPAREN);
     case ']':
          return (TOK_RPAREN);
     case '.':
          c=inchar(sc);
          if(is_one_of(" \n\t",c)) {
               return (TOK_DOT);
          } else {
               backchar(sc,c);
               backchar(sc,'.');
               return TOK_ATOM;
          }
     case '\'':
          return (TOK_QUOTE);
     case ';':
           while ((c=inchar(sc)) != '\n' && c!=EOF)
             ;

#if SHOW_ERROR_LINE
           if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif

       if(c == EOF)
         { return (TOK_EOF); }
       else
         { return (token(sc));}
     case '"':
          return (TOK_DQUOTE);
     case BACKQUOTE:
          return (TOK_BQUOTE);
     case ',':
         if ((c=inchar(sc)) == '@') {
               return (TOK_ATMARK);
         } else {
               backchar(sc,c);
               return (TOK_COMMA);
         }
     case '#':
          c=inchar(sc);
          if (c == '[') {
               return (TOK_VEC);
          } else if(c == '!') {
               while ((c=inchar(sc)) != '\n' && c!=EOF)
                   ;

#if SHOW_ERROR_LINE
           if(c == '\n' && sc->load_stack[sc->file_i].kind & port_file)
             sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif

           if(c == EOF)
             { return (TOK_EOF); }
           else
             { return (token(sc));}
          } else {
               backchar(sc,c);
               if(is_one_of(" tfodxb\\",c)) {
                    return TOK_SHARP_CONST;
               } else {
                    return (TOK_SHARP);
               }
          }
     default:
          backchar(sc,c);
          return (TOK_ATOM);
     }
}

#define   ok_abbrev(x)   (is_pair(x) && cdr(x) == sc->NIL)

static void printslashstring(Lax *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,'"');
}


static void printatom(Lax *sc, pointer l, int f) {
  char *p;
  int len;
  atom2str(sc,l,f,&p,&len);
  putchars(sc,p,len);
}

static void atom2str(Lax *sc, pointer l, int f, char **pp, int *plen) {
     char *p;

     if (l == sc->NIL) {
          p = "()";
     } else if (l == sc->T) {
          p = "#+";
     } else if (l == sc->F) {
          p = "#f";
     } else if (l == sc->EOF_OBJ) {
          p = "#<EOF>";
     } else if (is_port(l)) {
          p = "#<PORT>";
     } else if (is_number(l)) {
          p = sc->strbuff;
          if (f <= 1 || f == 10) {
              if(num_is_integer(l)) {
                   snprintf(p, STRBUFFSIZE, "%ld", ivalue_unchecked(l));
              } else {
                   snprintf(p, STRBUFFSIZE, "%.10g", rvalue_unchecked(l));
                   f = strcspn(p, ".e");
                   if (p[f] == 0) {
                        p[f] = '.';
                        p[f+1] = '0';
                        p[f+2] = 0;
                   }
              }
          } else {
              long v = ivalue(l);
              if (f == 16) {
                  if (v >= 0)
                    snprintf(p, STRBUFFSIZE, "%lx", v);
                  else
                    snprintf(p, STRBUFFSIZE, "-%lx", -v);
              } else if (f == 8) {
                  if (v >= 0)
                    snprintf(p, STRBUFFSIZE, "%lo", v);
                  else
                    snprintf(p, STRBUFFSIZE, "-%lo", -v);
              } else if (f == 2) {
                  unsigned long b = (v < 0) ? -v : v;
                  p = &p[STRBUFFSIZE-1];
                  *p = 0;
                  do { *--p = (b&1) ? '1' : '0'; b >>= 1; } while (b != 0);
                  if (v < 0) *--p = '-';
              }
          }
     } else if (is_string(l)) {
          if (!f) {
               p = strvalue(l);
          } else {
               *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 ' ':
                    p = "#\\space";
                    break;
               case '\n':
                    p = "#\\newline";
                    break;
               case '\r':
                    p = "#\\return";
                    break;
               case '\t':
                    p = "#\\tab";
                    break;
               default:
#if USE_ASCII_NAMES
                    if(c==127) {
                         p = "#\\del";
                         break;
                    } else if(c<32) {
                         snprintf(p,STRBUFFSIZE, "#\\%s",charnames[c]);
                         break;
                    }
#else
                    if(c<32) {
                      snprintf(p,STRBUFFSIZE,"#\\x%x",c);
                      break;
                    }
#endif
                    snprintf(p,STRBUFFSIZE,"#\\%c",c);
                    break;
               }
          }
     } else if (is_symbol(l)) {
          p = symname(l);
     } else if (is_proc(l)) {
          p = sc->strbuff;
          snprintf(p,STRBUFFSIZE,"#<%s PROCEDURE %ld>", procname(l),procnum(l));
     } else if (is_macro(l)) {
          p = "#<MACRO>";
     } else if (is_closure(l)) {
          p = "#<CLOSURE>";
     } else if (is_promise(l)) {
          p = "#<PROMISE>";
     } else if (is_foreign(l)) {
          p = sc->strbuff;
          snprintf(p,STRBUFFSIZE,"#<FOREIGN PROCEDURE %ld>", procnum(l));
     } else if (is_continuation(l)) {
          p = "#<CONTINUATION>";
     } else {
          p = "#<ERROR>";
     }
     *pp=p;
     *plen=strlen(p);
}

static pointer mk_closure(Lax *sc, pointer c, pointer e) {
     pointer x = get_cell(sc, c, e);

     typeflag(x) = T_CLOSURE;
     car(x) = c;
     cdr(x) = e;
     return (x);
}

static pointer mk_continuation(Lax *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(Lax *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;
}

static pointer reverse(Lax *sc, pointer a) {
     pointer p = sc->NIL;

     for ( ; is_pair(a); a = cdr(a)) {
          p = cons(sc, car(a), p);
     }
     return (p);
}

static pointer reverse_in_place(Lax *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);
}

static pointer revappend(Lax *sc, pointer a, pointer b) {
    pointer result = a;
    pointer p = b;

    while (is_pair(p)) {
        result = cons(sc, car(p), result);
        p = cdr(p);
    }

    if (p == sc->NIL) {
        return result;
    }

    return sc->F;
}

int eqv(pointer a, pointer b) {
     if (is_string(a)) {
          if (is_string(b))
               return (strvalue(a) == strvalue(b));
          else
               return (0);
     } else if (is_number(a)) {
          if (is_number(b)) {
               if (num_is_integer(a) == num_is_integer(b))
                    return num_eq(nvalue(a),nvalue(b));
          }
          return (0);
     } else if (is_character(a)) {
          if (is_character(b))
               return charvalue(a)==charvalue(b);
          else
               return (0);
     } else if (is_port(a)) {
          if (is_port(b))
               return a==b;
          else
               return (0);
     } else if (is_proc(a)) {
          if (is_proc(b))
               return procnum(a)==procnum(b);
          else
               return (0);
     } else {
          return (a == b);
     }
}

#define is_true(p)       ((p) != sc->F)
#define is_false(p)      ((p) == sc->F)

#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++) {
    hashed = (hashed<<5) | (hashed>>(bits_per_int-5));
    hashed ^= *c;
  }
  return hashed % table_size;
}
#endif

#ifndef USE_ALIST_ENV

static void new_frame_in_env(Lax *sc, pointer old_env)
{
  pointer new_frame;

  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(Lax *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(Lax *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

static INLINE void new_frame_in_env(Lax *sc, pointer old_env)
{
  sc->envir = immutable_cons(sc, sc->NIL, old_env);
  setenvironment(sc->envir);
}

static INLINE void new_slot_spec_in_env(Lax *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(Lax *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

static INLINE void new_slot_in_env(Lax *sc, pointer variable, pointer value)
{
  new_slot_spec_in_env(sc, sc->envir, variable, value);
}

static INLINE void set_slot_in_env(Lax *sc, pointer slot, pointer value)
{
  cdr(slot) = value;
}

static INLINE pointer slot_value_in_env(pointer slot)
{
  return cdr(slot);
}

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

static pointer _Error_1(Lax *sc, const char *s, pointer a) {
     const char *str = s;
#if USE_ERROR_HOOK
     pointer x;
     pointer hdl=sc->ERROR_HOOK;
#endif

#if SHOW_ERROR_LINE
     char sbuf[STRBUFFSIZE];

     if (sc->load_stack[sc->file_i].kind & port_file &&
         sc->load_stack[sc->file_i].rep.stdio.file != stdin) {
       int ln = sc->load_stack[sc->file_i].rep.stdio.curr_line;
       const char *fname = sc->load_stack[sc->file_i].rep.stdio.filename;

       if(!fname) fname = "<unknown>";

       ln++;
       snprintf(sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);

       str = (const char*)sbuf;
     }
#endif

#if USE_ERROR_HOOK
     x=find_slot_in_env(sc,sc->envir,hdl,1);
    if (x != sc->NIL) {
         if(a!=0) {
               sc->code = cons(sc, cons(sc, sc->QUOTE, cons(sc,(a), sc->NIL)), sc->NIL);
         } else {
               sc->code = sc->NIL;
         }
         sc->code = cons(sc, mk_string(sc, str), sc->code);
         setimmutable(car(sc->code));
         sc->code = cons(sc, slot_value_in_env(x), sc->code);
         sc->op = (int)OP_EVAL;
         return sc->NIL;
    }
#endif

    if(a!=0) {
          sc->args = cons(sc, (a), sc->NIL);
    } else {
          sc->args = sc->NIL;
    }
    sc->args = cons(sc, mk_string(sc, str), sc->args);
    setimmutable(car(sc->args));
    sc->op = (int)OP_ERR0;
    
    putstr(sc, "\033[1;31mE0:\033[0m ");
    putstr(sc, str);
    if(a!=0) {
        putstr(sc, " ");
        sc->print_flag = 1;
        printatom(sc, a, 1); 
    }
    putstr(sc, "\n");
    
    sc->nesting = 0;
    
    if(sc->interactive_repl) {
         s_goto(sc,OP_T0LVL);
    } else {
         return sc->NIL;
    }
}
#define Error_1(sc,s, a) return _Error_1(sc,s,a)
#define Error_0(sc,s)    return _Error_1(sc,s,0)

#ifndef USE_Lax_STACK

struct dump_stack_frame {
  enum Lax_opcodes op;
  pointer args;
  pointer envir;
  pointer code;
};

#define STACK_GROWTH 3

static void s_save(Lax *sc, enum Lax_opcodes op, pointer args, pointer code)
{
  int nframes = (int)sc->dump;
  struct dump_stack_frame *next_frame;

  if (nframes >= sc->dump_size) {
    sc->dump_size += STACK_GROWTH;
    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(Lax *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->NIL;
}

static INLINE void dump_stack_reset(Lax *sc)
{
  sc->dump = (pointer)0;
}

static INLINE void dump_stack_initialize(Lax *sc)
{
  sc->dump_size = 0;
  sc->dump_base = NULL;
  dump_stack_reset(sc);
}

static void dump_stack_free(Lax *sc)
{
  free(sc->dump_base);
  sc->dump_base = NULL;
  sc->dump = (pointer)0;
  sc->dump_size = 0;
}

static INLINE void dump_stack_mark(Lax *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(Lax *sc)
{
  sc->dump = sc->NIL;
}

static INLINE void dump_stack_initialize(Lax *sc)
{
  dump_stack_reset(sc);
}

static void dump_stack_free(Lax *sc)
{
  sc->dump = sc->NIL;
}

static pointer _s_return(Lax *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(Lax *sc, enum Lax_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(Lax *sc)
{
  mark(sc->dump);
}
#endif

#define s_retbool(tf)    s_return(sc,(tf) ? sc->T : sc->F)

static pointer opexe_0(Lax *sc, enum Lax_opcodes op) {
     pointer x, y;

     switch (op) {
     case OP_LOAD:
          if(file_interactive(sc)) {
               fprintf(sc->outport->_object._port->rep.stdio.file,
               "Loading %s\n", strvalue(car(sc->args)));
          }
          if (!file_push(sc,strvalue(car(sc->args)))) {
               Error_1(sc,"unable to open", car(sc->args));
          }
      else
        {
          sc->args = mk_integer(sc,sc->file_i);
          s_goto(sc,OP_T0LVL);
        }

     case OP_T0LVL:
       sc->paren_error_printed = 0;
       if(sc->loadport->_object._port->kind & port_saw_EOF)
     {
       if(sc->file_i == 0)
     {
       sc->args=sc->NIL;
       if(!file_interactive(sc)) {
         s_return(sc,sc->value);
       }
     }
   else
     {
       file_pop(sc);
       s_return(sc,sc->value);
     }
     }

       if(file_interactive(sc))
     {
       sc->envir = sc->global_env;
       dump_stack_reset(sc);
       putstr(sc,"\n");
       putstr(sc,prompt);
     }

       sc->nesting=0;
       sc->save_inport=sc->inport;
       sc->inport = sc->loadport;
       s_save(sc,OP_T0LVL, sc->NIL, sc->NIL);
       s_save(sc,OP_VALUEPRINT, sc->NIL, sc->NIL);
       s_save(sc,OP_T1LVL, sc->NIL, sc->NIL);
       s_goto(sc,OP_READ_INTERNAL);

     case OP_T1LVL:
          sc->code = sc->value;
          
          if (is_symbol(sc->code)) {
              char *s = symname(sc->code);
              if (strcmp(s, "help") == 0 || strcmp(s, "exit") == 0 || strcmp(s, "quit") == 0) {
                  sc->code = cons(sc, sc->code, sc->NIL); 
              }
          }

          sc->inport=sc->save_inport;
          s_goto(sc,OP_EVAL);

     case OP_READ_INTERNAL:
          sc->tok = token(sc);
          if(sc->tok==TOK_EOF)
        { s_return(sc,sc->EOF_OBJ); }
          s_goto(sc,OP_RDSEXPR);

     case OP_GENSYM:
          s_return(sc, gensym(sc));

case OP_VALUEPRINT:
    if(sc->tracing) {
        putstr(sc,"\nGives: ");
    }
    
    if(file_interactive(sc)) {
        s_return(sc,sc->value);
    } else {
        s_return(sc,sc->value);
    }

       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:
#if USE_TRACING
       if(sc->tracing) {
         s_save(sc,OP_REAL_EVAL,sc->args,sc->code);
         sc->args=sc->code;
         putstr(sc,"\nEval: ");
         s_goto(sc,OP_P0LIST);
       }
     case OP_REAL_EVAL:
#endif
          if (is_symbol(sc->code)) {
               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))) {
                    sc->code = cdr(sc->code);
                    s_goto(sc,syntaxnum(x));
               } else {
                    s_save(sc,OP_E0ARGS, sc->NIL, sc->code);
                    sc->code = car(sc->code);
                    s_goto(sc,OP_EVAL);
               }
          } else {
               s_return(sc,sc->code);
          }

     case OP_E0ARGS:
          if (is_macro(sc->value)) {
               s_save(sc,OP_DOMICRO, 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:
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) {
               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 {
               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:
#if USE_TRACING
       if(sc->tracing) {
         s_save(sc,OP_REAL_APPLY,sc->args,sc->code);
         sc->print_flag = 1;
         putstr(sc,"\nApply to: ");
         s_goto(sc,OP_P0LIST);
       }
     case OP_REAL_APPLY:
#endif
          if (is_proc(sc->code)) {
               s_goto(sc,procnum(sc->code));
          } else if (is_foreign(sc->code))
            {
              push_recent_alloc(sc,sc->args,sc->NIL);
               x=sc->code->_object._ff(sc,sc->args);
               s_return(sc,x);
          } else if (is_closure(sc->code) || is_macro(sc->code)
             || is_promise(sc->code)) {
               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) {
               } 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)) {
               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_DOMICRO:
          sc->code = sc->value;
          s_goto(sc,OP_EVAL);

#if 1
     case OP_AST:
          {
               pointer f=find_slot_in_env(sc,sc->envir,sc->COMPILE_HOOK,1);
               if(f==sc->NIL) {
                    sc->value = sc->code;
               } else {
                    s_save(sc,OP_AST1,sc->args,sc->code);
                    sc->args=cons(sc,sc->code,sc->NIL);
                    sc->code=slot_value_in_env(f);
                    s_goto(sc,OP_APPLY);
               }
          }

     case OP_AST1:
          s_return(sc,mk_closure(sc, sc->value, sc->envir));

#else
     case OP_AST:
          s_return(sc,mk_closure(sc, sc->code, sc->envir));

#endif

     case OP_MKCLOSURE:
       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:
          s_return(sc,car(sc->code));

     case OP_DEF0:
          if(is_immutable(car(sc->code)))
            Error_1(sc,"define: unable to alter immutable", car(sc->code));

          if (is_pair(car(sc->code))) {
               x = caar(sc->code);
               sc->code = cons(sc, sc->LAMBDA, cons(sc, cdar(sc->code), cdr(sc->code)));
          } else {
               x = car(sc->code);
               sc->code = cadr(sc->code);
          }
          if (!is_symbol(x)) {
               Error_0(sc,"variable is not a symbol");
          }
          s_save(sc,OP_DEF1, sc->NIL, x);
          s_goto(sc,OP_EVAL);

     case OP_DEF1:
          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:
          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:
          if(is_immutable(car(sc->code)))
                Error_1(sc,"set!: unable to alter immutable variable",car(sc->code));
          s_save(sc,OP_SET1, sc->NIL, car(sc->code));
          sc->code = cadr(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_SET1:
          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:
          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:
          s_save(sc,OP_IF1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_IF1:
          if (is_true(sc->value))
               sc->code = car(sc->code);
          else
               sc->code = cadr(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_LET0:
          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:
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) {
               if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                    Error_1(sc, "Bad syntax of binding spec in let :",
                            car(sc->code));
               }
               s_save(sc,OP_LET1, sc->args, cdr(sc->code));
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {
               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:
          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))) {
               for (x = cadr(sc->code), sc->args = sc->NIL; x != sc->NIL; x = cdr(x)) {
                    if (!is_pair(x))
                        Error_1(sc, "Bad syntax of binding in let :", x);
                    if (!is_list(sc, car(x)))
                        Error_1(sc, "Bad syntax of binding in let :", car(x));
                    sc->args = cons(sc, caar(x), sc->args);
               }
               x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc->NIL, sc->args), cddr(sc->code)), sc->envir);
               new_slot_in_env(sc, car(sc->code), x);
               sc->code = cddr(sc->code);
               sc->args = sc->NIL;
          } else {
               sc->code = cdr(sc->code);
               sc->args = sc->NIL;
          }
          s_goto(sc,OP_BEGIN);

     case OP_LET0AST:
          if (car(sc->code) == sc->NIL) {
               new_frame_in_env(sc, sc->envir);
               sc->code = cdr(sc->code);
               s_goto(sc,OP_BEGIN);
          }
          if(!is_pair(car(sc->code)) || !is_pair(caar(sc->code)) || !is_pair(cdaar(sc->code))) {
               Error_1(sc,"Bad syntax of binding spec in let* :",car(sc->code));
          }
          s_save(sc,OP_LET1AST, cdr(sc->code), car(sc->code));
          sc->code = cadaar(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_LET1AST:
          new_frame_in_env(sc, sc->envir);
          s_goto(sc,OP_LET2AST);

     case OP_LET2AST:
          new_slot_in_env(sc, caar(sc->code), sc->value);
          sc->code = cdr(sc->code);
          if (is_pair(sc->code)) {
               s_save(sc,OP_LET2AST, sc->args, sc->code);
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {
               sc->code = sc->args;
               sc->args = sc->NIL;
               s_goto(sc,OP_BEGIN);
          }

      case OP_INPUT: {
          char *line;
          char *p_str;

          if (sc->args != sc->NIL && is_string(car(sc->args))) {
              p_str = string_value(car(sc->args));
          } else {
              p_str = prompt;
          }

          if (sc->outport->_object._port->kind & port_file) {
              fflush(sc->outport->_object._port->rep.stdio.file);
          }

          line = linenoise(p_str);

          if (line != NULL) {
              pointer s = mk_string(sc, line);
              linenoiseFree(line);
              s_return(sc, s);
          } else {
              s_return(sc, sc->EOF_OBJ);
          }
       }
       default:
          s_return(sc, sc->NIL);
    }
}

static pointer opexe_1(Lax *sc, enum Lax_opcodes op) {
     pointer x, y;
     
     switch (op) {
     case OP_LET0REC:
          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:
          sc->args = cons(sc, sc->value, sc->args);
          if (is_pair(sc->code)) {
               if (!is_pair(car(sc->code)) || !is_pair(cdar(sc->code))) {
                    Error_1(sc, "Bad syntax of binding spec in letrec :",
                            car(sc->code));
               }
               s_save(sc,OP_LET1REC, sc->args, cdr(sc->code));
               sc->code = cadar(sc->code);
               sc->args = sc->NIL;
               s_goto(sc,OP_EVAL);
          } else {
               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:
          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:
          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:
          if (is_true(sc->value)) {
               if ((sc->code = cdar(sc->code)) == sc->NIL) {
                    s_return(sc,sc->value);
               }
               if(!sc->code || 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_TARRY:
          x = mk_closure(sc, cons(sc, sc->NIL, sc->code), sc->envir);
          typeflag(x)=T_PROMISE;
          s_return(sc,x);

     case OP_AND0:
          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:
          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:
          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:
          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:
          s_save(sc,OP_C1STREAM, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_C1STREAM:
          sc->args = sc->value;
          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:
          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:
          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:
          s_save(sc,OP_CASE1, sc->NIL, cdr(sc->code));
          sc->code = car(sc->code);
          s_goto(sc,OP_EVAL);

     case OP_CASE1:
          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 {
                    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:
          if (is_true(sc->value)) {
               s_goto(sc,OP_BEGIN);
          } else {
               s_return(sc,sc->NIL);
          }

     case OP_PAPPLY:
          sc->code = car(sc->args);
          sc->args = list_star(sc,cdr(sc->args));
          s_goto(sc,OP_APPLY);

     case OP_PEVAL:
          if(cdr(sc->args)!=sc->NIL) {
               sc->envir=cadr(sc->args);
          }
          sc->code = car(sc->args);
          s_goto(sc,OP_EVAL);

     case OP_CONTINUATION:
          sc->code = car(sc->args);
          sc->args = cons(sc, mk_continuation(sc, sc->dump), sc->NIL);
          s_goto(sc,OP_APPLY);

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

static pointer opexe_2(Lax *sc, enum Lax_opcodes op) {
     pointer x;
     num v;
#if USE_MATH
     double dd;
#endif

     switch (op) {
#if USE_MATH
     case OP_INEX2EX:
          x=car(sc->args);
          if(num_is_integer(x)) {
               s_return(sc,x);
          } else if(modf(rvalue_unchecked(x),&dd)==0.0) {
               s_return(sc,mk_integer(sc,ivalue(x)));
          } else {
               Error_1(sc,"inexact->exact: not integral:",x);
          }
          
case OP_TARRY: {
     double val = rvalue(car(sc->args));
     unsigned long ms = (unsigned long)val;
     
     if(sc->outport->_object._port->kind & port_file) {
          fflush(sc->outport->_object._port->rep.stdio.file);
     }
     fflush(stdout);
     
     if (ms > 0) {
#ifdef _WIN32
          Sleep(ms);
#else
          usleep(ms * 1000);
#endif
     }
     
     s_return(sc, sc->T);
}

     case OP_EXP:
          x=car(sc->args);
          s_return(sc, mk_real(sc, exp(rvalue(x))));

     case OP_LOG:
          x=car(sc->args);
          s_return(sc, mk_real(sc, log(rvalue(x))));

     case OP_SIN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, sin(rvalue(x))));

     case OP_COS:
          x=car(sc->args);
          s_return(sc, mk_real(sc, cos(rvalue(x))));

     case OP_TAN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, tan(rvalue(x))));

     case OP_ASIN:
          x=car(sc->args);
          s_return(sc, mk_real(sc, asin(rvalue(x))));

     case OP_ACOS:
          x=car(sc->args);
          s_return(sc, mk_real(sc, acos(rvalue(x))));

     case OP_ATAN:
          x=car(sc->args);
          if(cdr(sc->args)==sc->NIL) {
               s_return(sc, mk_real(sc, atan(rvalue(x))));
          } else {
               pointer y=cadr(sc->args);
               s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
          }

     case OP_SQRT:
          x=car(sc->args);
          s_return(sc, mk_real(sc, sqrt(rvalue(x))));

     case OP_EXPT: {
          double result;
          int real_result=1;
          pointer y=cadr(sc->args);
          x=car(sc->args);
          if (num_is_integer(x) && num_is_integer(y))
             real_result=0;
          if (rvalue(x) == 0 && rvalue(y) < 0) {
             result = 0.0;
          } else {
             result = pow(rvalue(x),rvalue(y));
          }
          if (!real_result)
          {
            long result_as_long = (long)result;
            if (result != (double)result_as_long)
              real_result = 1;
          }
          if (real_result) {
             s_return(sc, mk_real(sc, result));
          } else {
             s_return(sc, mk_integer(sc, result));
          }
     }

     case OP_FLOOR:
          x=car(sc->args);
          s_return(sc, mk_real(sc, floor(rvalue(x))));

     case OP_CEILING:
          x=car(sc->args);
          s_return(sc, mk_real(sc, ceil(rvalue(x))));

     case OP_TRUNCATE : {
          double rvalue_of_x ;
          x=car(sc->args);
          rvalue_of_x = rvalue(x) ;
          if (rvalue_of_x > 0) {
            s_return(sc, mk_real(sc, floor(rvalue_of_x)));
          } else {
            s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
          }
     }

     case OP_ROUND:
        x=car(sc->args);
        if (num_is_integer(x))
            s_return(sc, x);
        s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
#endif

     case OP_ADD:
       v=num_zero;
       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
         v=num_add(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_MUL:
       v=num_one;
       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
         v=num_mul(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_SUB:
       if(cdr(sc->args)==sc->NIL) {
         x=sc->args;
         v=num_zero;
       } else {
         x = cdr(sc->args);
         v = nvalue(car(sc->args));
       }
       for (; x != sc->NIL; x = cdr(x)) {
         v=num_sub(v,nvalue(car(x)));
       }
       s_return(sc,mk_number(sc, v));

     case OP_DIV:
       if(cdr(sc->args)==sc->NIL) {
         x=sc->args;
         v=num_one;
       } else {
         x = cdr(sc->args);
         v = nvalue(car(sc->args));
       }
       for (; x != sc->NIL; x = cdr(x)) {
         if (!is_zero_double(rvalue(car(x))))
           v=num_div(v,nvalue(car(x)));
         else {
           Error_0(sc,"/: division by zero");
         }
       }
       s_return(sc,mk_number(sc, v));

     case OP_INTDIV:
          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:
          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:
          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_HEAD:
          s_return(sc,caar(sc->args));

     case OP_TAIL:
          s_return(sc,cdar(sc->args));

     case OP_CONS:
          cdr(sc->args) = cadr(sc->args);
          s_return(sc,sc->args);

     case OP_SETHEAD:
       if(!is_immutable(car(sc->args))) {
         caar(sc->args) = cadr(sc->args);
         s_return(sc,car(sc->args));
       } else {
         Error_0(sc,"set-head!: unable to alter immutable pair");
       }

     case OP_SETTAIL:
       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 c;
          c=(char)ivalue(car(sc->args));
          s_return(sc,mk_integer(sc,(unsigned char)c));
     }

     case OP_INT2CHAR: {
          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_STR2SIGN:
          s_return(sc,mk_symbol(sc,strvalue(car(sc->args))));

     case OP_STR2ATOM: {
          char *s=strvalue(car(sc->args));
          long pf = 0;
          if(cdr(sc->args)!=sc->NIL) {
            pf = ivalue_unchecked(cadr(sc->args));
            if(pf == 16 || pf == 10 || pf == 8 || pf == 2) {
            }
            else {
              pf = -1;
            }
          }
          if (pf < 0) {
            Error_1(sc, "string->atom: bad base:", cadr(sc->args));
          } else if(*s=='#') {
            s_return(sc, mk_sharp_const(sc, s+1));
          } else {
            if (pf == 0 || pf == 10) {
              s_return(sc, mk_atom(sc, s));
            }
            else {
              char *ep;
              long iv = strtol(s,&ep,(int )pf);
              if (*ep == 0) {
                s_return(sc, mk_integer(sc, iv));
              }
              else {
                s_return(sc, sc->F);
              }
            }
          }
        }

     case OP_SYM2STR:
          x=mk_string(sc,symname(car(sc->args)));
          setimmutable(x);
          s_return(sc,x);

     case OP_ATOM2STR: {
          long pf = 0;
          x=car(sc->args);
          if(cdr(sc->args)!=sc->NIL) {
            pf = ivalue_unchecked(cadr(sc->args));
            if(is_number(x) && (pf == 16 || pf == 10 || pf == 8 || pf == 2)) {
            }
            else {
              pf = -1;
            }
          }
          if (pf < 0) {
            Error_1(sc, "atom->string: bad base:", cadr(sc->args));
          } else if(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
            char *p;
            int len;
            atom2str(sc,x,(int )pf,&p,&len);
            s_return(sc,mk_counted_string(sc,p,len));
          } else {
            Error_1(sc, "atom->string: not an atom:", x);
          }
        }

     case OP_MKSTRING: {
          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:
          s_return(sc,mk_integer(sc,strlength(car(sc->args))));

     case OP_STRREF: {
          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: {
          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: {
       int len = 0;
       pointer newstr;
       char *pos;

       for (x = sc->args; x != sc->NIL; x = cdr(x)) {
          len += strlength(car(x));
       }
       newstr = mk_empty_string(sc, len, ' ');
       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: {
          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: {
          int i;
          pointer vec;
          int len=list_length(sc,sc->args);
          if(len<0) {
               Error_1(sc,"vector: not a proper list:",sc->args);
          }
          vec=mk_vector(sc,len);
          if(sc->no_memory) { s_return(sc, sc->sink); }
          for (x = sc->args, i = 0; is_pair(x); x = cdr(x), i++) {
               set_vector_elem(vec,i,car(x));
          }
          s_return(sc,vec);
     }

     case OP_MKVECTOR: {
          pointer fill=sc->NIL;
          int len;
          pointer vec;

          len=ivalue(car(sc->args));

          if(cdr(sc->args)!=sc->NIL) {
               fill=cadr(sc->args);
          }
          vec=mk_vector(sc,len);
          if(sc->no_memory) { s_return(sc, sc->sink); }
          if(fill!=sc->NIL) {
               fill_vector(vec,fill);
          }
          s_return(sc,vec);
     }

     case OP_VECLEN:
          s_return(sc,mk_integer(sc,ivalue(car(sc->args))));

     case OP_VECREF: {
          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: {
          int index;

          if(is_immutable(car(sc->args))) {
               Error_1(sc,"vector-set!: unable to alter immutable vector:",car(sc->args));
          }

          index=ivalue(cadr(sc->args));
          if(index>=ivalue(car(sc->args))) {
               Error_1(sc,"vector-set!: out of bounds:",cadr(sc->args));
          }

          set_vector_elem(car(sc->args),index,caddr(sc->args));
          s_return(sc,car(sc->args));
     }

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

static int is_list(Lax *sc, pointer a)
{ return list_length(sc,a) >= 0; }

int list_length(Lax *sc, pointer a) {
    int i=0;
    pointer slow, fast;

    slow = fast = a;
    while (1)
    {
        if (fast == sc->NIL)
                return i;
        if (!is_pair(fast))
                return -2 - i;
        fast = cdr(fast);
        ++i;
        if (fast == sc->NIL)
                return i;
        if (!is_pair(fast))
                return -2 - i;
        ++i;
        fast = cdr(fast);

        slow = cdr(slow);
        if (fast == slow)
        {
            return -1;
        }
    }
}

static pointer opexe_3(Lax *sc, enum Lax_opcodes op) {
     pointer x;
     num v;
     int (*comp_func)(num,num)=0;

     switch (op) {
     case OP_NOT:
          s_retbool(is_false(car(sc->args)));
     case OP_BOOLP:
          s_retbool(car(sc->args) == sc->F || car(sc->args) == sc->T);
     case OP_EOFOBJP:
          s_retbool(car(sc->args) == sc->EOF_OBJ);
     case OP_NULLP:
          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_SIGNP:
          s_retbool(is_symbol(car(sc->args)));
     case OP_NUMBERP:
          s_retbool(is_number(car(sc->args)));
     case OP_STRINGP:
          s_retbool(is_string(car(sc->args)));
     case OP_INTEGERP:
          s_retbool(is_integer(car(sc->args)));
     case OP_REALP:
          s_retbool(is_number(car(sc->args)));
     case OP_CHARP:
          s_retbool(is_character(car(sc->args)));
#if USE_CHAR_CLASSIFIERS
     case OP_CHARAP:
          s_retbool(Cisalpha(ivalue(car(sc->args))));
     case OP_CHARNP:
          s_retbool(Cisdigit(ivalue(car(sc->args))));
     case OP_CHARWP:
          s_retbool(Cisspace(ivalue(car(sc->args))));
     case OP_CHARUP:
          s_retbool(Cisupper(ivalue(car(sc->args))));
     case OP_CHARLP:
          s_retbool(Cislower(ivalue(car(sc->args))));
#endif
     case OP_PORTP:
          s_retbool(is_port(car(sc->args)));
     case OP_INPORTP:
          s_retbool(is_inport(car(sc->args)));
     case OP_OUTPORTP:
          s_retbool(is_outport(car(sc->args)));
     case OP_PROCP:
          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:
          s_retbool(is_pair(car(sc->args)));
     case OP_LISTP:
       s_retbool(list_length(sc,car(sc->args)) >= 0);

     case OP_ENVP:
          s_retbool(is_environment(car(sc->args)));
     case OP_VECTORP:
          s_retbool(is_vector(car(sc->args)));
     case OP_EQ:
          s_retbool(car(sc->args) == cadr(sc->args));
     case OP_EQV:
          s_retbool(eqv(car(sc->args), cadr(sc->args)));
     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

static pointer opexe_4(Lax *sc, enum Lax_opcodes op) {
     pointer x, y;

     switch (op) {
     case OP_FORCE:
          sc->code = car(sc->args);
          if (is_promise(sc->code)) {
               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:
          memcpy(sc->code,sc->value,sizeof(struct cell));
          s_return(sc,sc->value);

case OP_IMAGE:
    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);
        }
    }

    x = car(sc->args);

    if (is_string(x)) {
        char *str = strvalue(x);
        int len = strlength(x);
        int i;

        for (i = 0; i < len; i++) {
            if (str[i] == '\\' && i + 1 < len) {
                switch (str[i + 1]) {
                    case 'n': putcharacter(sc, '\n'); i++; break;
                    case 't': putcharacter(sc, '\t'); i++; break;
                    case 'r': putcharacter(sc, '\r'); i++; break;
                    case '\\': putcharacter(sc, '\\'); i++; break;
                    default: putcharacter(sc, str[i]); break;
                }
            } else {
                putcharacter(sc, str[i]);
            }
        }
        
        if (sc->outport->_object._port->kind & port_file) {
            fflush(sc->outport->_object._port->rep.stdio.file);
        }
        
        s_return(sc, sc->T);
    }

    sc->print_flag = 0; 
    sc->args = x;
    
    s_goto(sc,OP_P0LIST);

     case OP_NEWLINE:
          putstr(sc, "\n");
          if(sc->outport->_object._port->kind & port_file) {
              fflush(sc->outport->_object._port->rep.stdio.file);
          }
          s_return(sc, sc->T);

     case OP_ERR0:
          sc->retcode=-1;
          if (!is_string(car(sc->args))) {
               sc->args=cons(sc,mk_string(sc," -- "),sc->args);
               setimmutable(car(sc->args));
          }
          Error_1(sc, strvalue(car(sc->args)), 0); 

     case OP_ERR1: 
         s_return(sc, sc->NIL);

     case OP_REVERSE:
          s_return(sc,reverse(sc, car(sc->args)));

     case OP_LIST_STAR:
          s_return(sc,list_star(sc,sc->args));

     case OP_APPEND:
          x = sc->NIL;
          y = sc->args;
          if (y == x) {
              s_return(sc, x);
          }
          while (cdr(y) != sc->NIL) {
              x = revappend(sc, x, car(y));
              y = cdr(y);
              if (x == sc->F) {
                  Error_0(sc, "non-list argument to append");
              }
          }
          s_return(sc, reverse_in_place(sc, car(y), x));

#if USE_PLIST
     case OP_PUT:
          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:
          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 

     case OP_GC:
          gc(sc, sc->NIL, sc->NIL);
          s_return(sc,sc->T);

     case OP_GCVERB:
     {    int  was = sc->gc_verbose;

          sc->gc_verbose = (car(sc->args) != sc->F);
          s_retbool(was);
     }

     case OP_NEWSEGMENT:
          if (!is_pair(sc->args) || !is_number(car(sc->args))) {
               Error_0(sc,"Error: argument must be a number");
          }
          alloc_cellseg(sc, (int) ivalue(car(sc->args)));
          s_return(sc,sc->T);

     case OP_OBLIST:
          s_return(sc, oblist_all_symbols(sc));

     case OP_CURR_INPORT:
          s_return(sc,sc->inport);

     case OP_CURR_OUTPORT:
          s_return(sc,sc->outport);

     case OP_OPEN_INFILE:
     case OP_OPEN_OUTFILE:
     case OP_OPEN_INOUTFILE: {
          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:
     case OP_OPEN_INOUTSTRING: {
          int prop=0;
          pointer p;
          switch(op) {
               case OP_OPEN_INSTRING:     prop=port_input; break;
               case OP_OPEN_INOUTSTRING:  prop=port_input|port_output; break;
          }
          p=port_from_string(sc, strvalue(car(sc->args)),
                 strvalue(car(sc->args))+strlength(car(sc->args)), prop);
          if(p==sc->NIL) {
               s_return(sc,sc->F);
          }
          s_return(sc,p);
     }
     case OP_OPEN_OUTSTRING: {
          pointer p;
          if(car(sc->args)==sc->NIL) {
               p=port_from_scratch(sc);
               if(p==sc->NIL) {
                    s_return(sc,sc->F);
               }
          } else {
               p=port_from_string(sc, strvalue(car(sc->args)),
                      strvalue(car(sc->args))+strlength(car(sc->args)),
                          port_output);
               if(p==sc->NIL) {
                    s_return(sc,sc->F);
               }
          }
          s_return(sc,p);
     }
     case OP_GET_OUTSTRING: {
          port *p;

          if ((p=car(sc->args)->_object._port)->kind&port_string) {
               off_t size;
               char *str;

               size=p->rep.string.curr-p->rep.string.start+1;
               str=sc->malloc(size);
               if(str != NULL) {
                    pointer s;

                    memcpy(str,p->rep.string.start,size-1);
                    str[size-1]='\0';
                    s=mk_string(sc,str);
                    sc->free(str);
                    s_return(sc,s);
               }
          }
          s_return(sc,sc->F);
     }
#endif

     case OP_CLOSE_INPORT:
          port_close(sc,car(sc->args),port_input);
          s_return(sc,sc->T);

     case OP_CLOSE_OUTPORT:
          port_close(sc,car(sc->args),port_output);
          s_return(sc,sc->T);

     case OP_INT_ENV:
          s_return(sc,sc->global_env);

     case OP_CURR_ENV:
          s_return(sc,sc->envir);

     }
     return sc->NIL;
}

static pointer opexe_5(Lax *sc, enum Lax_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) {
     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:
     case OP_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: {
          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:
          sc->inport=car(sc->args);
          s_return(sc,sc->value);

     case OP_SET_OUTPORT:
          sc->outport=car(sc->args);
          s_return(sc,sc->value);

     case OP_RDSEXPR:
          switch (sc->tok) {
          case TOK_EOF:
               s_return(sc,sc->EOF_OBJ);
          case TOK_VEC:
               s_save(sc,OP_RDVEC,sc->NIL,sc->NIL);
          case TOK_LPAREN:
               sc->tok = token(sc);
               if (sc->tok == TOK_RPAREN) {
                    s_return(sc,sc->NIL);
               } else if (sc->tok == TOK_DOT) {
                    Error_0(sc,"syntax error: illegal dot expression");
               } else {
                    sc->nesting_stack[sc->file_i]++;
                    s_save(sc,OP_RDLIST, sc->NIL, sc->NIL);
                    s_goto(sc,OP_RDSEXPR);
               }
          case TOK_QUOTE:
               s_save(sc,OP_RDQUOTE, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_BQUOTE:
               sc->tok = token(sc);
               if(sc->tok==TOK_VEC) {
                 s_save(sc,OP_RDQQUOTEVEC, sc->NIL, sc->NIL);
                 sc->tok=TOK_LPAREN;
                 s_goto(sc,OP_RDSEXPR);
               } else {
                 s_save(sc,OP_RDQQUOTE, sc->NIL, sc->NIL);
               }
               s_goto(sc,OP_RDSEXPR);
          case TOK_COMMA:
               s_save(sc,OP_RDUNQUOTE, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_ATMARK:
               s_save(sc,OP_RDUQTSP, sc->NIL, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          case TOK_ATOM:
               s_return(sc,mk_atom(sc, readstr_upto(sc, DELIMITERS)));
          case TOK_DQUOTE:
               x=readstrexp(sc);
               if(x==sc->F) {
                 Error_0(sc,"Error reading string");
               }
               setimmutable(x);
               s_return(sc,x);
          case TOK_SHARP: {
               pointer f=find_slot_in_env(sc,sc->envir,sc->SHARP_HOOK,1);
               if(f==sc->NIL) {
                    Error_0(sc,"undefined sharp expression");
               } else {
                    sc->code=cons(sc,slot_value_in_env(f),sc->NIL);
                    s_goto(sc,OP_EVAL);
               }
          }
          case TOK_SHARP_CONST:
               if ((x = mk_sharp_const(sc, readstr_upto(sc, DELIMITERS))) == sc->NIL) {
                    Error_0(sc,"undefined sharp expression");
               } else {
                    s_return(sc,x);
               }
          default:
               Error_0(sc,"syntax error: illegal token");
          }
          break;

     case OP_RDLIST: {
          sc->args = cons(sc, sc->value, sc->args);
          sc->tok = token(sc);
          if (sc->tok == TOK_EOF)
               { s_return(sc,sc->EOF_OBJ); }
          else if (sc->tok == TOK_RPAREN) {
               int c = inchar(sc);
               if (c != '\n')
                 backchar(sc,c);
#if SHOW_ERROR_LINE
               else if (sc->load_stack[sc->file_i].kind & port_file)
                  sc->load_stack[sc->file_i].rep.stdio.curr_line++;
#endif
               sc->nesting_stack[sc->file_i]--;
               s_return(sc,reverse_in_place(sc, sc->NIL, sc->args));
          } else if (sc->tok == TOK_DOT) {
               s_save(sc,OP_RDDOT, sc->args, sc->NIL);
               sc->tok = token(sc);
               s_goto(sc,OP_RDSEXPR);
          } else {
               s_save(sc,OP_RDLIST, sc->args, sc->NIL);;
               s_goto(sc,OP_RDSEXPR);
          }
     }

     case OP_RDDOT:
          if (token(sc) != TOK_RPAREN) {
               Error_0(sc,"syntax error: illegal dot expression");
          } else {
               sc->nesting_stack[sc->file_i]--;
               s_return(sc,reverse_in_place(sc, sc->value, sc->args));
          }

     case OP_RDQUOTE:
          s_return(sc,cons(sc, sc->QUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDQQUOTE:
          s_return(sc,cons(sc, sc->QQUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDQQUOTEVEC:
           s_return(sc,cons(sc, mk_symbol(sc,"apply"),
           cons(sc, mk_symbol(sc,"vector"),
                 cons(sc,cons(sc, sc->QQUOTE,
                  cons(sc,sc->value,sc->NIL)),
                  sc->NIL))));

     case OP_RDUNQUOTE:
          s_return(sc,cons(sc, sc->UNQUOTE, cons(sc, sc->value, sc->NIL)));

     case OP_RDUQTSP:
          s_return(sc,cons(sc, sc->UNQUOTESP, cons(sc, sc->value, sc->NIL)));

     case OP_RDVEC:
          sc->args=sc->value;
          s_goto(sc,OP_VECTOR);

     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>");
        if(sc->interactive_repl) { putstr(sc, "\n"); }
        s_return(sc,sc->T);
    } else if (!is_pair(sc->args)) {
        printatom(sc, sc->args, sc->print_flag);
        if(sc->interactive_repl) { 
            putstr(sc, "\n"); 
        }
        if (sc->outport->_object._port->kind & port_file) {
            fflush(sc->outport->_object._port->rep.stdio.file);
        }
        s_return(sc, sc->args);
    } 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, ")");
        
        if (sc->interactive_repl) {
            putstr(sc, "\n");
        }
        
        s_return(sc, sc->T);
    }

     case OP_PVECFROM: {
          int i=ivalue_unchecked(cdr(sc->args));
          pointer vec=car(sc->args);
          int len=ivalue_unchecked(vec);
          if(i==len) {
               putstr(sc,"]");
               s_return(sc,sc->T);
          } else {
               pointer elem=vector_elem(vec,i);
               ivalue_unchecked(cdr(sc->args))=i+1;
               s_save(sc,OP_PVECFROM, sc->args, sc->NIL);
               sc->args=elem;
               if (i > 0)
                   putstr(sc," ");
               s_goto(sc,OP_P0LIST);
          }
     }

     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);

     }
     return sc->T;
}

static pointer opexe_6(Lax *sc, enum Lax_opcodes op) {
     pointer x, y;
     long v;

     switch (op) {
     case OP_LIST_LENGTH:
          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:
          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:
          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:
          s_retbool(is_closure(car(sc->args)));
     case OP_MICROP:
          s_retbool(is_macro(car(sc->args)));
     default:
          snprintf(sc->strbuff,STRBUFFSIZE,"%d: illegal operator", sc->op);
          Error_0(sc,sc->strbuff);
     }
     return sc->T;
}

typedef pointer (*dispatch_func)(Lax *, enum Lax_opcodes);

typedef int (*test_predicate)(pointer);
static int is_any(pointer p) { return 1;}

static int is_nonneg(pointer p) {
  return ivalue(p)>=0 && is_integer(p);
}

static struct {
  test_predicate fct;
  const char *kind;
} tests[]={
  {0,0},
  {is_any, 0},
  {is_string, "string"},
  {is_symbol, "symbol"},
  {is_port, "port"},
  {is_inport,"input port"},
  {is_outport,"output port"},
  {is_environment, "environment"},
  {is_pair, "pair"},
  {0, "pair or '()"},
  {is_character, "character"},
  {is_vector, "vector"},
  {is_number, "number"},
  {is_integer, "integer"},
  {is_nonneg, "non-negative integer"}
};

#define TST_NONE 0
#define TST_ANY "\001"
#define TST_STRING "\002"
#define TST_SYMBOL "\003"
#define TST_PORT "\004"
#define TST_INPORT "\005"
#define TST_OUTPORT "\006"
#define TST_ENVIRONMENT "\007"
#define TST_PAIR "\010"
#define TST_LIST "\011"
#define TST_CHAR "\012"
#define TST_VECTOR "\013"
#define TST_NUMBER "\014"
#define TST_INTEGER "\015"
#define TST_NATURAL "\016"

typedef struct {
  dispatch_func func;
  char *name;
  int min_arity;
  int max_arity;
  char *arg_tests_encoding;
} op_code_info;

#define INF_ARG 0xffff

static op_code_info dispatch_table[]= {
#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E},
#include "com.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;
}

static void Eval_Cycle(Lax *sc, enum Lax_opcodes op) {
  sc->op = op;
  for (;;) {
    op_code_info *pcd=dispatch_table+sc->op;
    if (pcd->name!=0) {
      char msg[STRBUFFSIZE];
      int ok=1;
      int n=list_length(sc,sc->args);

      if(n<pcd->min_arity) {
        ok=0;
        snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
        pcd->name,
        pcd->min_arity==pcd->max_arity?"":" at least",
        pcd->min_arity);
      }
      if(ok && n>pcd->max_arity) {
        ok=0;
        snprintf(msg, STRBUFFSIZE, "%s: needs%s %d argument(s)",
        pcd->name,
        pcd->min_arity==pcd->max_arity?"":" at most",
        pcd->max_arity);
      }
      if(ok) {
        if(pcd->arg_tests_encoding!=0) {
          int i=0;
          int j;
          const char *t=pcd->arg_tests_encoding;
          pointer arglist=sc->args;
          do {
            pointer arg=car(arglist);
            j=(int)t[0];
            if(j==TST_LIST[0]) {
                  if(arg!=sc->NIL && !is_pair(arg)) break;
            } else {
              if(!tests[j].fct(arg)) break;
            }

            if(t[1]!=0) {
              t++;
            }
            arglist=cdr(arglist);
            i++;
          } while(i<n);
          if(i<n) {
            ok=0;
            snprintf(msg, STRBUFFSIZE, "%s: argument %d must be: %s",
                pcd->name,
                i+1,
                tests[j].kind);
          }
        }
      }
      if(!ok) {
        if(_Error_1(sc,msg,0)==sc->NIL) {
          return;
        }
        pcd=dispatch_table+sc->op;
      }
    }
    ok_to_freely_gc(sc);
    if (pcd->func(sc, (enum Lax_opcodes)sc->op) == sc->NIL) {
      return;
    }
    if(sc->no_memory) {
      fprintf(stderr,"No memory!\n");
      return;
    }
  }
}

static void assign_syntax(Lax *sc, char *name) {
     pointer x;

     x = oblist_add_by_name(sc, name);
     typeflag(x) |= T_SYNTAX;
}

static void assign_proc(Lax *sc, enum Lax_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(Lax *sc, enum Lax_opcodes op) {
     pointer y;

     y = get_cell(sc, sc->NIL, sc->NIL);
     typeflag(y) = (T_PROC | T_ATOM);
     ivalue_unchecked(y) = (long) op;
     set_num_integer(y);
     return y;
}

static int syntaxnum(pointer p) {
     const char *s=strvalue(car(p));
     switch(strlength(car(p))) {
     case 2:
          if(s[0]=='i') return OP_IF0;
          else return OP_OR0;
     case 3:
          if(s[0]=='a') {
              if (s[1]=='s') return OP_AST;
              return OP_AND0;
          }
          return OP_LET0;
     case 4:
          if(strcmp(s, "spot") == 0) return OP_DEF0;
          switch(s[3]) {
          case 'e': return OP_CASE0;
          case 'd': return OP_COND0;
          case '*': return OP_LET0AST;
          case 't': return OP_DEF0;
          default: return OP_SET0;
          }
     case 5:
          if(strcmp(s, "chlet") == 0) return OP_COND0;
          if(strcmp(s, "start") == 0) return OP_BEGIN;
          if(strcmp(s, "micro") == 0) return OP_MACRO0;
          if(strcmp(s, "cite") == 0) return OP_QUOTE;
          switch(s[2]) {
          case 'g': return OP_BEGIN;
          case 'l': return OP_TARRY;
          case 'c': return OP_MACRO0;
          default: return OP_QUOTE;
          }
     case 6:
          if(strcmp(s, "ast") == 0) return OP_AST;
          switch(s[2]) {
          case 'm': return OP_AST;
          case 'f': return OP_DEF0;
          default: return OP_LET0REC;
          }
     default:
          return OP_C0STREAM;
     }
}

#if USE_INTERFACE
INTERFACE static pointer s_cons(Lax *sc, pointer a, pointer b) {
 return cons(sc,a,b);
}
INTERFACE static pointer s_immutable_cons(Lax *sc, pointer a, pointer b) {
 return immutable_cons(sc,a,b);
}

static struct Lax_interface vtbl ={
  Lax_define,
  s_cons,
  s_immutable_cons,
  reserve_cells,
  mk_integer,
  mk_real,
  mk_symbol,
  gensym,
  mk_string,
  mk_counted_string,
  mk_character,
  mk_vector,
  mk_foreign_func,
  putstr,
  putcharacter,

  is_string,
  string_value,
  is_number,
  nvalue,
  ivalue,
  rvalue,
  is_integer,
  is_real,
  is_character,
  charvalue,
  is_list,
  is_vector,
  list_length,
  ivalue,
  fill_vector,
  vector_elem,
  set_vector_elem,
  is_port,
  is_pair,
  pair_car,
  pair_cdr,
  set_car,
  set_cdr,

  is_symbol,
  symname,

  is_syntax,
  is_proc,
  is_foreign,
  syntaxname,
  is_closure,
  is_macro,
  closure_code,
  closure_env,

  is_continuation,
  is_promise,
  is_environment,
  is_immutable,
  setimmutable,

  Lax_load_file,
  Lax_load_string
};
#endif

static pointer
lax_help(Lax *sc, pointer args)
{
    (void) args;

    puts("Available commands:");
    puts("");
    puts("Regular commands:");
    puts("  image         - Print a line to the current output");
    puts("  say           - Print a line with "" to the current output and return #+");
    puts("  exit          - Exit REPL and return to shell");
    puts("  help          - Show this help text");
    puts("  nl            - Call a new line (Wrap)");
    puts("  err           - Raise an error with your message");
    puts("");
    puts("Conditional commands:");
    puts("  if            - Condition if ...");
    puts("  start         - Execute multiple statements in a row");
    puts("  spot          - Create a global or local name-to-value binding");
    puts("  and           - output a newline on the current output port");
    puts("  or            - output a newline on the current output port");
    puts("  =             - Compare the first and second values");
    puts("  <             - The second value is greater than the first");
    puts("  >             - The first value is greater than the second");
    puts("  <=            - The first and second values ​​are equal or the second value is greater");
    puts("  >=            - The first and second values ​​are equal or the first value is greater");
    puts("");
    puts("Commands for working with data:");
    puts("  ast           - Create an executable object that can be called later");
    puts("  cite          - Prevent expression evaluation");
    puts("  set$          - Edit an existing binding");
    puts("  let           - Create a temporary environment with new bindings");
    puts("  let$          - Create a chain of dependent bindings");
    puts("  let*          - Let bindings reference each other");
    puts("  chlet         - Selects the first suitable branch");
    puts("  chlet-stream  - Create a lazy pair");
    puts("  micro         - Changes code before execution");
    puts("  syntax-rules  - pattern macros > likely absent");
    puts("  {quasiquote                                              ");
    puts("  {unquote      - Template construction (`), used by macros");
    puts("  {unquote-splicing                                        ");
    puts("  choose        - Selects a branch by value");
    puts("");
    puts("I/O and ports");
    puts("  read          - Read one Lax expression from current input");
    puts("  head          - First element of pair/list");
    puts("  tail          - Tail (rest) of pair/list");
    puts("  read-char     - Read next character from current input port");
    puts("  peek-char     - Peek next char without consuming it");
    puts("  say-char      - Say a single character to output");
    puts("  eof-object?   - Test for end-of-file marker");
    puts("  open-i/o-file - Open a file as input/output port");
    puts("  close-i/o-port- Close port");
    puts("  load          - Load and evaluate expressions from a file");
    puts("  load-extension- Load shared library (dynamic extension)");
    puts("current-input-port- Get current input");
    puts("current-output-port- Get current output");
    puts("  set-input-port - Change current input");
    puts("  set-output-port- Change current output");
    puts("open-input-string- Create port from string");
    puts("get-output-string- Get string from accumulated port");
    puts("");
    puts("System:");
    puts("  system        - Execute a system command, return status/output (if present)");
    puts("  file-exists?  - Test file presence");
    puts("  gc            - Force garbage collection");
    puts("  gc-verbose    - Toggle GC verbosity");
    puts("  oblist        - Return list of all interned symbols");
    puts("  new-segment   - Allocate new memory segment");
    puts("  defined?      - Check if a symbol is defined");
    puts("  quit          - Immediately terminate the REPL and subsequent execution");
    puts("");
    puts("Call and functions:");
    puts("  apply         - Apply procedure to list of args");
    puts("  eval          - Evaluate Lax expression in current environment");
    puts("  map           - Map function over list(s), return new list");
    puts("  for-each      - Apply function to list elements for side-effects (no result list)");
    puts("--- Low-level/auxiliary (functions and commands) ---");
    puts(" apply-primitive- Low-level/auxiliary function");
    puts("  compose       - Low-level/auxiliary command");
    puts("");
    puts("Lists:");
    puts("  cons          - Create pair from two values");
    puts("  list*         - Create improper list (last arg is tail)");
    puts("  reverse       - Reverse a list");
    puts("  append        - Concatenate lists");
    puts("  head          - First element (car)");
    puts("  tail          - Rest of list (cdr)");
    puts("  set-head!     - Modify the head (car) of a pair");
    puts("  set-tail!     - Modify the tail (cdr) of a pair");
    puts("  assq          - Find pair by key (using eq?)");
    puts("  memq, memv    - Membership tests");
    puts("");
    puts("Type Tests:");
    puts("  number?       - Test number");
    puts("  integer?      - Test integer");
    puts("  sign?         - Test symbol");
    puts("  string?       - Reverse a list");
    puts("  boolean?      - Test for empty list");
    puts("  {char?                         ");
    puts("  {char=?       - char predicates");
    puts("  {char<?                        ");
    puts("  procedure?    - Test if value is callable");
    puts("  port?         - Test whether object is port");
    puts("  list?         - Test if value is a proper list");
    puts("  vector?       - Test if value is a vector");
    puts("  environment?  - Test if value is an environment");
    puts("  input-port?   - Test for input port");
    puts("  output-port?  - Test for output port");
    puts("  closure?      - Test if value is a closure");
    puts("  micro?        - Test if value is a macro");
    puts("");
    puts("String operations:");
    puts("  string-length - Length of string");
    puts("  string-ref    - Char at index");
    puts("  string-set!   - Mutate char in string");
    puts("  substring     - Extract substring");
    puts("  string-append - Concatenate strings");
    puts("  make-string   - Create a string of defined length");
    puts("  char->integer - Convert char to ASCII code");
    puts("  integer->char - Convert code to char");
    puts("  char-upcase   - Convert char to upper case");
    puts("  char-downcase - Convert char to lower case");
    puts("char-alphabetic?- Is char a letter?");
    puts("  char-numeric? - Is char a digit?");
    puts("char-whitespace?- Is char a space/tab/nl?");
    puts("{string->symbol |}");
    puts("{symbol->string - Conversions");
    puts("-");
    puts("  {string=?     |}");
    puts("  {string<?     - String compares");
    puts("");
    puts("Symbols:");
    puts("  symbol->string- Convert symbol to string");
    puts("  string->symbol- Convert string to symbol");
    puts("  gensym        - Generate new unique symbol");
    puts("");
    puts("Logic:");
    puts("  not           - Logical negation");
    puts("  {eq?                                       ");
    puts("  {eqv?         - Different equality notions:");
    puts("  {equal?                                    ");
    puts("  eq?           - identity (pointer-level)");
    puts("  eqv?          - like eq? but for numbers/booleans treats equal values");
    puts("  equal?        - deep structural equality (lists, strings...)");
    puts("");
    puts("Arithmetic functions:");
    puts("  +             - Add one value to another");
    puts("  -             - Subtract one value from another");
    puts("  *             - Multiply one value by another");
    puts("  /             - Divide one value by another");
    puts("-");
    puts("  {abs          |}               ");
    puts("  {quotient     - integer helpers");
    puts("  {remainder    |}               ");
    puts("  {modulo       |}               ");
    puts("-");
    puts("  {floor        |}        ");
    puts("  {ceiling      - rounding");
    puts("  {round        |}        ");
    puts("  {truncate     |}        ");
    puts("  max           - Maximum");
    puts("  min           - Minimum");
    puts("");
    puts("Math & Trigonometry:");
    puts("  exp, log      - Exponential and natural logarithm");
    puts("  sin, cos, tan - Trigonometric functions");
    puts("  asin, acos    - Arc trigonometric functions");
    puts("  atan          - Arc tangent");
    puts("  sqrt          - Square root");
    puts("  expt          - Exponentiation (power)");
    puts("  inexact->exact- Convert float to integer");
    puts("Vector");
    puts("  vector        - Create vector from args");
    puts("  make-vector   - Create vector of length n w/ initial value");
    puts("  vector-ref    - Read vector element");
    puts("  vector-set!   - Write vector element");
    puts("  vector-length - Length");
    puts("");
    puts("Streams:");
    puts("  tarry         - Wait for the specified time before executing");
    puts("  stream        - helpers > map/for-each variants for streams");
    puts("  force         - Evaluate a delayed promise");
    puts("");

    return sc->NIL;
}

static pointer
lax_exit(Lax *sc, pointer args)
{
    (void) sc;
    (void) args;
    
    puts("Thank you for using Lax 6.0!");
    sleep(1);
    puts("Bye!");
    sleep(1);
    fflush(stdout);

    exit(0);
}

static pointer
lax_quit(Lax *sc, pointer args)
{
    (void) sc;
    (void) args;
    
    fflush(stdout);

    exit(0);
}

Lax *Lax_init_new() {
  Lax *sc=(Lax*)malloc(sizeof(Lax));
  if(!Lax_init(sc)) {
    free(sc);
    return 0;
  } else {
    return sc;
  }
}

Lax *Lax_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
  Lax *sc=(Lax*)malloc(sizeof(Lax));
  if(!Lax_init_custom_alloc(sc,malloc,free)) {
    free(sc);
    return 0;
  } else {
    return sc;
  }
}


int Lax_init(Lax *sc) {
 return Lax_init_custom_alloc(sc,malloc,free);
}

int Lax_init_custom_alloc(Lax *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->paren_error_printed=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;

  typeflag(sc->NIL) = (T_ATOM | MARK);
  car(sc->NIL) = cdr(sc->NIL) = sc->NIL;
  typeflag(sc->T) = (T_ATOM | MARK);
  car(sc->T) = cdr(sc->T) = sc->T;
  typeflag(sc->F) = (T_ATOM | MARK);
  car(sc->F) = cdr(sc->F) = sc->F;
  typeflag(sc->sink) = (T_PAIR | MARK);
  car(sc->sink) = sc->NIL;
  sc->c_nest = sc->NIL;

  sc->oblist = oblist_initial_value(sc);
  new_frame_in_env(sc, sc->NIL);
  sc->global_env = sc->envir;
  x = mk_symbol(sc,"else");
  new_slot_in_env(sc, x, sc->T);

  assign_syntax(sc, "ast");
  assign_syntax(sc, "cite");
  assign_syntax(sc, "spot");
  assign_syntax(sc, "if");
  assign_syntax(sc, "start");
  assign_syntax(sc, "set$");
  assign_syntax(sc, "let");
  assign_syntax(sc, "let$");
  assign_syntax(sc, "let*");
  assign_syntax(sc, "chlet");
  assign_syntax(sc, "and");
  assign_syntax(sc, "or");
  assign_syntax(sc, "chlet-stream");
  assign_syntax(sc, "micro");
  assign_syntax(sc, "choose");

  for(i=0; i<n; i++) {
    if(dispatch_table[i].name!=0) {
      assign_proc(sc, (enum Lax_opcodes)i, dispatch_table[i].name);
    }
  }
  
Lax_define(sc, sc->global_env, mk_symbol(sc, "help"), mk_foreign_func(sc, lax_help));
Lax_define(sc, sc->global_env, mk_symbol(sc, "exit"), mk_foreign_func(sc, lax_exit));
Lax_define(sc, sc->global_env, mk_symbol(sc, "quit"), mk_foreign_func(sc, lax_quit));

  sc->LAMBDA = mk_symbol(sc, "ast");
  sc->QUOTE = mk_symbol(sc, "cite");
  sc->QQUOTE = mk_symbol(sc, "quasiquote");
  sc->UNQUOTE = mk_symbol(sc, "unquote");
  sc->UNQUOTESP = mk_symbol(sc, "unquote-splicing");
  sc->FEED_TO = mk_symbol(sc, "=>");
  sc->COLON_HOOK = mk_symbol(sc,"*colon-hook*");
  sc->ERROR_HOOK = mk_symbol(sc, "*error-hook*");
  sc->SHARP_HOOK = mk_symbol(sc, "*sharp-hook*");
  sc->COMPILE_HOOK = mk_symbol(sc, "*compile-hook*");

  return !sc->no_memory;
}

void Lax_set_input_port_file(Lax *sc, FILE *fin) {
  sc->inport=port_from_file(sc,fin,port_input);
}

void Lax_set_input_port_string(Lax *sc, char *start, char *past_the_end) {
  sc->inport=port_from_string(sc,start,past_the_end,port_input);
}

void Lax_set_output_port_file(Lax *sc, FILE *fout) {
  sc->outport=port_from_file(sc,fout,port_output);
}

void Lax_set_output_port_string(Lax *sc, char *start, char *past_the_end) {
  sc->outport=port_from_string(sc,start,past_the_end,port_output);
}

void Lax_set_external_data(Lax *sc, void *p) {
 sc->ext_data=p;
}

void Lax_deinit(Lax *sc) {
  int i;

#if SHOW_ERROR_LINE
  char *fname;
#endif

  sc->oblist=sc->NIL;
  sc->global_env=sc->NIL;
  dump_stack_free(sc);
  sc->envir=sc->NIL;
  sc->code=sc->NIL;
  sc->args=sc->NIL;
  sc->value=sc->NIL;
  if(is_port(sc->inport)) {
    typeflag(sc->inport) = T_ATOM;
  }
  sc->inport=sc->NIL;
  sc->outport=sc->NIL;
  if(is_port(sc->save_inport)) {
    typeflag(sc->save_inport) = T_ATOM;
  }
  sc->save_inport=sc->NIL;
  if(is_port(sc->loadport)) {
    typeflag(sc->loadport) = T_ATOM;
  }
  sc->loadport=sc->NIL;
  sc->gc_verbose=0;
  gc(sc,sc->NIL,sc->NIL);

  for(i=0; i<=sc->last_cell_seg; i++) {
    sc->free(sc->alloc_seg[i]);
  }

#if SHOW_ERROR_LINE
  for(i=0; i<=sc->file_i; i++) {
    if (sc->load_stack[i].kind & port_file) {
      fname = sc->load_stack[i].rep.stdio.filename;
      if(fname)
        sc->free(fname);
    }
  }
#endif
}

void Lax_load_file(Lax *sc, FILE *fin)
{ Lax_load_named_file(sc,fin,0); }

void Lax_load_named_file(Lax *sc, FILE *fin, const char *filename) {
  dump_stack_reset(sc);
  sc->envir = sc->global_env;
  sc->file_i=0;
  
  sc->load_stack[0].kind = port_input | port_file; 
  sc->load_stack[0].kind &= ~port_saw_EOF; 
  
  sc->load_stack[0].rep.stdio.file = fin;
  sc->load_stack[0].rep.stdio.closeit = 0;

  sc->loadport=mk_port(sc,sc->load_stack);
  sc->retcode=0;
  
  if(fin==stdin) {
    sc->interactive_repl=1;
    clearerr(stdin); 
  }

#if SHOW_ERROR_LINE
  sc->load_stack[0].rep.stdio.curr_line = 0;
  if(fin!=stdin && filename)
    sc->load_stack[0].rep.stdio.filename = store_string(sc, strlen(filename), filename, 0);
  else
    sc->load_stack[0].rep.stdio.filename = NULL;
#endif

  sc->inport=sc->loadport;
  sc->args = mk_integer(sc,sc->file_i);
  Eval_Cycle(sc, OP_T0LVL);
  typeflag(sc->loadport)=T_ATOM;
  if(sc->retcode==0) {
    sc->retcode=sc->nesting!=0;
  }
}

void Lax_load_string(Lax *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;
  sc->load_stack[0].rep.string.past_the_end=(char*)cmd+strlen(cmd);
  sc->load_stack[0].rep.string.curr=(char*)cmd;
  sc->loadport=mk_port(sc,sc->load_stack);
  sc->retcode=0;
  sc->interactive_repl=0;
  sc->inport=sc->loadport;
  sc->args = mk_integer(sc,sc->file_i);
  Eval_Cycle(sc, OP_T0LVL);
  typeflag(sc->loadport)=T_ATOM;
  if(sc->retcode==0) {
    sc->retcode=sc->nesting!=0;
  }
}

void Lax_define(Lax *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 Lax_register_foreign_func(Lax * sc, Lax_registerable * sr)
{
  Lax_define(sc,
                sc->global_env,
                mk_symbol(sc,sr->name),
                mk_foreign_func(sc, sr->f));
}

void Lax_register_foreign_func_list(Lax * sc,
                                       Lax_registerable * list,
                                       int count)
{
  int i;
  for(i = 0; i < count; i++)
    {
      Lax_register_foreign_func(sc, list + i);
    }
}

pointer Lax_apply0(Lax *sc, const char *procname)
{ return Lax_eval(sc, cons(sc,mk_symbol(sc,procname),sc->NIL)); }

void save_from_C_call(Lax *sc)
{
  pointer saved_data =
    cons(sc,
         car(sc->sink),
         cons(sc,
              sc->envir,
              sc->dump));
  sc->c_nest = cons(sc, saved_data, sc->c_nest);
  dump_stack_reset(sc);
}
void restore_from_C_call(Lax *sc)
{
  car(sc->sink) = caar(sc->c_nest);
  sc->envir = cadar(sc->c_nest);
  sc->dump = cdr(cdar(sc->c_nest));
  sc->c_nest = cdr(sc->c_nest);
}

pointer Lax_call(Lax *sc, pointer func, pointer args)
{
  int old_repl = sc->interactive_repl;
  sc->interactive_repl = 0;
  save_from_C_call(sc);
  sc->envir = sc->global_env;
  sc->args = args;
  sc->code = func;
  sc->retcode = 0;
  Eval_Cycle(sc, OP_APPLY);
  sc->interactive_repl = old_repl;
  restore_from_C_call(sc);
  return sc->value;
}

pointer Lax_eval(Lax *sc, pointer obj)
{
  int old_repl = sc->interactive_repl;
  sc->interactive_repl = 0;
  save_from_C_call(sc);
  sc->args = sc->NIL;
  sc->code = obj;
  sc->retcode = 0;
  Eval_Cycle(sc, OP_EVAL);
  sc->interactive_repl = old_repl;
  restore_from_C_call(sc);
  return sc->value;
}


#endif

#if STANDALONE

void type_print(const char *s) {
    while (*s) {
        putchar(*s++);
        fflush(stdout);
        usleep(500); 
    }
}

void print_footer(const char *progname, const char *version) {
    int use_color = isatty(fileno(stdout));

    const char *C_RST  = use_color ? "\x1b[0m"  : "";
    const char *C_HDR  = use_color ? "\x1b[1;36m" : "";
    const char *C_KEY  = use_color ? "\x1b[1;33m" : "";
    const char *C_OPT  = use_color ? "\x1b[0;37m" : "";

    char buf[1024];

    snprintf(buf, sizeof(buf), "%s+----------------------------------------+\n", C_HDR);
    type_print(buf);

    type_print("|                                        |\n");

    snprintf(buf, sizeof(buf), "|   %sLax%s — Ultra lightweight language     |\n", C_KEY, C_HDR);
    type_print(buf);

    type_print("|                                        |\n");

    snprintf(buf, sizeof(buf), "+----------------------------------------+\n\n");
    type_print(buf);

    snprintf(buf, sizeof(buf), "%s%s %s\n\n", C_HDR, progname, version);
    type_print(buf);

    snprintf(buf, sizeof(buf), "%sUsage:%s\n", C_KEY, C_RST);
    type_print(buf);

    type_print("  -i              : Interactive Mode (REPL)\n");
    type_print("  -o <file.lx>    : Run a script file (interpreter)\n");
    type_print("  -c <file.lx>    : Compile .c and binary program\n\n");

    snprintf(buf, sizeof(buf), "%sMore:%s\n", C_KEY, C_RST);
    type_print(buf);

    type_print("  Authors : Anthony Lubmansky, Mavox-ID, N467, NeedYOU7\n");
    type_print("  Company : https://github.com/lax-Inc\n");
    type_print("  Repo    : https://github.com/lax-Inc/Lax\n\n");
    
}

const char *PAYLOAD_MARKER = "####LAX_DCODE####";

void minify_lax_code(char *code) {
    char *src = code;
    char *dst = code;
    int in_string = 0;
    int in_comment = 0;

    while (*src) {
        if (!in_comment && *src == '"') {
            in_string = !in_string;
        }

        if (!in_string && *src == ';') {
            in_comment = 1;
        }

        if (in_comment) {
            if (*src == '\n' || *src == '\r') {
                in_comment = 0;
                *dst++ = *src;
            }
        } else {
            *dst++ = *src;
        }
        src++;
    }
    *dst = '\0';
}

int load_embedded_script(Lax *sc, const char *exe_path) {
    FILE *fp = fopen(exe_path, "rb");
    if (!fp) return 0;
    
    fseek(fp, 0, SEEK_END);
    long size = ftell(fp);
    fseek(fp, 0, SEEK_SET);
    
    char *data = malloc(size + 1);
    if (!data) { fclose(fp); return 0; }
    
    size_t read_bytes = fread(data, 1, size, fp);
    data[read_bytes] = '\0';
    fclose(fp);

    char *payload = NULL;
    size_t marker_len = strlen(PAYLOAD_MARKER);
    
    for (long i = (long)read_bytes - (long)marker_len - 1; i >= 0; i--) {
        if (memcmp(data + i, PAYLOAD_MARKER, marker_len) == 0) {
            payload = data + i + marker_len;
            break;
        }
    }
    
    if (payload && *payload) {
        Lax_load_string(sc, (const char*)init_lx); 
        
        Lax_load_string(sc, payload);
        
        free(data);
        return 1;
    }
    
    free(data);
    return 0;
}

#if defined(__APPLE__) && !defined (OSX)
int main() {
     extern int MacTS_main(int argc, char **argv);
     char** argv;
     int argc = ccommand(&argv);
     return MacTS_main(argc,argv);
}
int MacTS_main(int argc, char **argv) {
#else
int main(int argc, char **argv) {
#endif
  Lax sc;
  FILE *fin;
  int retcode;

  if(!Lax_init(&sc)) {
    fprintf(stderr,"Could not initialize!\n");
    return 2;
  }

  Lax_set_input_port_file(&sc, stdin);
  Lax_set_output_port_file(&sc, stdout);

  if (load_embedded_script(&sc, argv[0])) {
    retcode = sc.retcode;
    Lax_deinit(&sc);
    return retcode;
  }

  if(argc == 1) {
    print_footer("Lax", "6.0 (6.0.6) Lax Inc. (C) Anthony Lubmansky, Mavox-ID, N467, NeedYOU7");
    Lax_deinit(&sc);
    return 0;
  }

  if(strcmp(argv[1], "-i") == 0) {
      Lax_load_string(&sc, (const char*)init_lx);

      printf("Lax 6.0 (6.0.7) Lax Inc. (C) Anthony Lubmansky, Mavox-ID, N467, NeedYOU7\n");
      printf("Type 'help' for a menu of available commands\n\n");
      
      char *line;
      linenoiseHistoryLoad(".lax_history");
      linenoiseSetMultiLine(1);

      while((line = linenoise("Lax> ")) != NULL) {
          if (line[0] != '\0') {
              linenoiseHistoryAdd(line);
              linenoiseHistorySave(".lax_history");
              Lax_load_string(&sc, line);
          }
          linenoiseFree(line);
      }
  } 
  else if(strcmp(argv[1], "-o") == 0) {
    if(argc < 3) {
        fprintf(stderr, "Error: filename required for -o\n");
        Lax_deinit(&sc);
        return 1;
    }
    
    Lax_load_string(&sc, (const char*)init_lx);
    
    fin = fopen(argv[2], "r");
    if(fin) {
        Lax_load_named_file(&sc, fin, argv[2]);
        fclose(fin);
    } else {
        fprintf(stderr, "Cannot open file: %s\n", argv[2]);
    }
  }
  else if(strcmp(argv[1], "-c") == 0) {
      FILE *fp_src, *fp_exe, *fp_out;
      char out_name[1024];
      char script_buf[65536];
      size_t script_len, exe_len;
      char *exe_data;

      if(argc < 3) {
          fprintf(stderr, "Error: filename required for -c\n");
          Lax_deinit(&sc);
          return 1;
      }
      
      strcpy(out_name, argv[2]);
      char *dot = strrchr(out_name, '.');
      if(dot) *dot = '\0';
      
      fp_src = fopen(argv[2], "r");
      if(!fp_src) {
          fprintf(stderr, "Cannot open source: %s\n", argv[2]);
          Lax_deinit(&sc);
          return 1;
      }

      script_len = fread(script_buf, 1, sizeof(script_buf) - 1, fp_src);
      script_buf[script_len] = '\0';
      fclose(fp_src);

      minify_lax_code(script_buf);

      printf("Compiling %s -> binary '%s'...\n", argv[2], out_name);

      fp_exe = fopen(argv[0], "rb");
      if(!fp_exe) {
          fprintf(stderr, "Cannot read Lax executable\n");
          Lax_deinit(&sc);
          return 1;
      }
      
      fseek(fp_exe, 0, SEEK_END);
      exe_len = ftell(fp_exe);
      fseek(fp_exe, 0, SEEK_SET);
      
      exe_data = malloc(exe_len);
      if(!exe_data) {
          fprintf(stderr, "Memory allocation failed\n");
          fclose(fp_exe);
          Lax_deinit(&sc);
          return 1;
      }
      
      if (fread(exe_data, 1, exe_len, fp_exe) != exe_len) {
          fprintf(stderr, "Error reading executable data\n");
      }
      fclose(fp_exe);

      fp_out = fopen(out_name, "wb");
      if(!fp_out) {
          fprintf(stderr, "Cannot create binary %s\n", out_name);
          free(exe_data);
          Lax_deinit(&sc);
          return 1;
      }

      fwrite(exe_data, 1, exe_len, fp_out);
      fprintf(fp_out, "%s", PAYLOAD_MARKER);
      fwrite(script_buf, 1, strlen(script_buf), fp_out);
      
      fclose(fp_out);
      free(exe_data);

#ifndef WIN32
      chmod(out_name, 0755);
#endif

      printf("Success! Generated binary: %s\n", out_name);
      Lax_deinit(&sc);
      return 0;
  }
  else {
      printf("Unknown argument: %s\n", argv[1]);
  }

  retcode = sc.retcode;
  Lax_deinit(&sc);
  return retcode;
}
#endif