/* -*- C++ -*-
// -------------------------------------------------------------------
// MiniExp - Library for handling lisp expressions
// Copyright (c) 2005  Leon Bottou
//
// This software is subject to, and may be distributed under, the
// GNU General Public License, either version 2 of the license
// or (at your option) any later version. The license should have
// accompanied the software or you may obtain a copy of the license
// from the Free Software Foundation at http://www.fsf.org .
//
// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
// -------------------------------------------------------------------
*/

#ifdef HAVE_CONFIG_H
# include "config.h"
#endif
#if NEED_GNUG_PRAGMAS
# pragma implementation "miniexp.h"
#endif

#include <stddef.h>
#include <stdlib.h>
#include <stdio.h>
#include <ctype.h>
#include <errno.h>
#include <string.h>
#include <time.h>
#include <stdarg.h>

#define MINIEXP_IMPLEMENTATION

#include "miniexp.h"

#ifdef HAVE_NAMESPACES
# define BEGIN_ANONYMOUS_NAMESPACE namespace {
# define END_ANONYMOUS_NAMESPACE }
#else
# define BEGIN_ANONYMOUS_NAMESPACE 
# define END_ANONYMOUS_NAMESPACE
#endif


/* -------------------------------------------------- */
/* ASSERT                                            */
/* -------------------------------------------------- */

#if defined(__GNUC__)
static void 
assertfail(const char *fn, int ln) 
  __attribute__((noreturn));
#endif

static void
assertfail(const char *fn, int ln)
{
  fprintf(stderr,"Assertion failed: %s:%d\n",fn,ln);
  abort();
}

#define ASSERT(x) \
  do { if (!(x)) assertfail(__FILE__,__LINE__); } while(0)


/* -------------------------------------------------- */
/* GLOBAL MUTEX                                       */
/* -------------------------------------------------- */

#ifndef WITHOUT_THREADS
# ifdef _WIN32
#  include <windows.h>
#  define USE_WINTHREADS 1
# elif defined(HAVE_PTHREAD)
#  include <pthread.h>
#  define USE_PTHREADS 1 
# endif
#endif

#if defined(USE_WINTHREADS)
// Windows critical section
# define CSLOCK(name) CSLocker name
BEGIN_ANONYMOUS_NAMESPACE
struct CS { 
  CRITICAL_SECTION cs; 
  CS() { InitializeCriticalSection(&cs); }
  ~CS() { DeleteCriticalSection(&cs); } };
static CS globalCS;
struct CSLocker {
  CSLocker() { EnterCriticalSection(&globalCS.cs); }
  ~CSLocker() { LeaveCriticalSection(&globalCS.cs); } };
END_ANONYMOUS_NAMESPACE

#elif defined (USE_PTHREADS)
// Pthread critical section
# define CSLOCK(name) CSLocker name
BEGIN_ANONYMOUS_NAMESPACE
static pthread_mutex_t globalCS = PTHREAD_MUTEX_INITIALIZER;
struct CSLocker {
  CSLocker() { pthread_mutex_lock(&globalCS); }
  ~CSLocker() { pthread_mutex_unlock(&globalCS); } };
END_ANONYMOUS_NAMESPACE
  
#else
// No critical sections
# define CSLOCK(name) /**/
#endif


/* -------------------------------------------------- */
/* SYMBOLS                                            */
/* -------------------------------------------------- */

static unsigned int 
hashcode(const char *s)
{
  long h = 0x1013;
  while (*s)
    {
      h = (h<<6) | ((h&0xfc000000)>>26);
      h ^= (*s);
      s++;
    }
  return h;
}

BEGIN_ANONYMOUS_NAMESPACE

class symtable_t 
{
public:
  int nelems;
  int nbuckets;
  struct sym { unsigned int h; struct sym *l; char *n; };
  struct sym **buckets;
  symtable_t();
  ~symtable_t();
  struct sym *lookup(const char *n, bool create=false);
  void resize(int); 
private:
  symtable_t(const symtable_t&);
  symtable_t& operator=(const symtable_t&);
};

symtable_t::symtable_t()
  : nelems(0), nbuckets(0), buckets(0)
{
  resize(7);
}

symtable_t::~symtable_t()
{
  int i=0;
  for (; i<nbuckets; i++)
    while (buckets[i])
      {
        struct sym *r = buckets[i];
        buckets[i] = r->l;
        delete [] r->n;
        delete r;
      }
  delete [] buckets;
}

void
symtable_t::resize(int nb)
{
  struct sym **b = new sym*[nb];
  memset(b, 0, nb*sizeof(sym*));
  int i=0;
  for (; i<nbuckets; i++)
    while (buckets[i])
      {
        struct sym *s = buckets[i];
        int j = s->h % nb;
        buckets[i] = s->l;
        s->l = b[j];
        b[j] = s;
      }
  delete [] buckets;
  buckets = b;
  nbuckets = nb;
}

struct symtable_t::sym *
symtable_t::lookup(const char *n, bool create)
{
  unsigned int h = hashcode(n);
  int i = h % nbuckets;
  struct sym *r = buckets[i];
  while (r && strcmp(n,r->n))
    r = r->l;
  if (!r && create)
    {
      CSLOCK(lock);
      nelems += 1;
      r = new sym;
      r->h = h;
      r->l = buckets[i];
      r->n = new char [1+strlen(n)];
      strcpy(r->n, n);
      buckets[i] = r;
      if ( 2 * nelems > 3 * nbuckets)
        resize(2*nbuckets-1);
    }
  return r;
}
  
END_ANONYMOUS_NAMESPACE

static symtable_t *symbols;
 
const char *
miniexp_to_name(miniexp_t p)
{
  if (miniexp_symbolp(p))
    {
      struct symtable_t::sym *r;
      r = ((symtable_t::sym*)(((size_t)p)&~((size_t)3)));
      return (r) ? r->n : "##(dummy)";
    }
  return 0;
}

miniexp_t 
miniexp_symbol(const char *name)
{
  struct symtable_t::sym *r;
  if (! symbols)
    {
      CSLOCK(lock);
      if (! symbols)
        symbols = new symtable_t;
    }
  r = symbols->lookup(name, true);
  return (miniexp_t)(((size_t)r)|((size_t)2));
}


/* -------------------------------------------------- */
/* MEMORY AND GARBAGE COLLECTION                      */
/* -------------------------------------------------- */

// A simple mark-and-sweep garbage collector.
//
// Memory is managed in chunks of nptrs_chunk pointers.
// The first two pointers are used to hold mark bytes for the rest.
// Chunks are carved from blocks of nptrs_block pointers.
//
// Dirty hack: The sixteen most recently created pairs are 
// not destroyed by automatic garbage collection, in order
// to preserve transient objects created in the course 
// of evaluating complicated expressions.

#define nptrs_chunk  (4*sizeof(void*))
#define sizeof_chunk (nptrs_chunk*sizeof(void*))
#define nptrs_block  (16384-8)
#define recentlog    (4)
#define recentsize   (1<<recentlog)

BEGIN_ANONYMOUS_NAMESPACE

struct gctls_t {
  gctls_t  *next;
  gctls_t **pprev;
  void    **recent[recentsize];
  int       recentindex;
  gctls_t();
  ~gctls_t();
};

struct block_t 
{
  block_t *next;
  void **lo;
  void **hi;
  void *ptrs[nptrs_block];
};

static struct {
  int lock;
  int request;
  int debug;
  int      pairs_total;
  int      pairs_free;
  void   **pairs_freelist;
  block_t *pairs_blocks;
  int      objs_total;
  int      objs_free;
  void   **objs_freelist;
  block_t *objs_blocks;
  gctls_t *tls;
} gc;

gctls_t::gctls_t()
{
  // CSLOCK(locker); [already locked]
  recentindex = 0;
  for (int i=0; i<recentsize; i++)
    recent[i] = 0;
  if ((next = gc.tls))
    next->pprev = &next;
  pprev = &gc.tls;
  gc.tls = this;
  //fprintf(stderr,"Created gctls %p\n", this);
}

gctls_t::~gctls_t()
{
  //CSLOCK(locker); [already locked]
  //fprintf(stderr,"Deleting gctls %p\n", this);
  if  ((*pprev = next))
    next->pprev = pprev;
}

END_ANONYMOUS_NAMESPACE

#if USE_PTHREADS
// Manage thread specific data with pthreads
static pthread_key_t gctls_key;
static pthread_once_t gctls_once;
static void gctls_destroy(void* arg) {
  CSLOCK(locker); delete (gctls_t*)arg;
}
static void gctls_key_alloc() {
  pthread_key_create(&gctls_key, gctls_destroy);
}
# if HAVE_GCCTLS
static __thread gctls_t *gctls_tv = 0;
static void gctls_alloc() {
  pthread_once(&gctls_once, gctls_key_alloc);
  gctls_tv = new gctls_t();
  pthread_setspecific(gctls_key, (void*)gctls_tv);
}
static gctls_t *gctls() {
  if (! gctls_tv) gctls_alloc();
  return gctls_tv;
}
# else
static  gctls_t *gctls_alloc() {
  gctls_t *res = new gctls_t();
  pthread_setspecific(gctls_key, (void*)res);
  return res;
}
static gctls_t *gctls() {
  pthread_once(&gctls_once, gctls_key_alloc);
  void *arg = pthread_getspecific(gctls_key);
  return (arg) ? (gctls_t*)(arg) : gctls_alloc();
}
# endif

#elif USE_WINTHREADS 
// Manage thread specific data with win32
#if defined(_MSC_VER) && defined(USE_MSVC_TLS)
// -- Pre-vista os sometimes crashes on this.
static __declspec(thread) gctls_t *gctls_tv = 0;
static gctls_t *gctls() {
  if (! gctls_tv)  gctls_tv = new gctls_t();
  return gctls_tv;
}
static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {
  if (dwReason == DLL_THREAD_DETACH && gctls_tv) 
    { CSLOCK(locker); delete gctls_tv; gctls_tv=0; } }
# else
// -- Using Tls{Alloc,SetValue,GetValue,Free} instead.
static DWORD tlsIndex = TLS_OUT_OF_INDEXES;
static gctls_t *gctls() {
  if (tlsIndex == TLS_OUT_OF_INDEXES) tlsIndex = TlsAlloc();
  ASSERT(tlsIndex != TLS_OUT_OF_INDEXES);
  gctls_t *addr = (gctls_t*)TlsGetValue(tlsIndex);
  if (! addr) TlsSetValue(tlsIndex, (LPVOID)(addr = new gctls_t()));
  ASSERT(addr != 0);
  return addr;
}
static void NTAPI gctls_cb(PVOID, DWORD dwReason, PVOID) {
  if (dwReason == DLL_THREAD_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)
    {CSLOCK(r);delete(gctls_t*)TlsGetValue(tlsIndex);TlsSetValue(tlsIndex,0);}
  if (dwReason == DLL_PROCESS_DETACH && tlsIndex != TLS_OUT_OF_INDEXES)
    {CSLOCK(r);TlsFree(tlsIndex);tlsIndex=TLS_OUT_OF_INDEXES;}
}
# endif
// -- Very black magic to clean tls variables.
# ifdef _M_IX86
#  pragma comment (linker, "/INCLUDE:_tlscb")
# else
#  pragma comment (linker, "/INCLUDE:tlscb")
# endif
# pragma const_seg(".CRT$XLB")
extern "C" PIMAGE_TLS_CALLBACK tlscb = gctls_cb;
# pragma const_seg()

#else
// No threads
static gctls_t *gctls() {
  static gctls_t g;
  return &g;
}

#endif

static inline char *
markbase(void **p)
{
  return (char*)(((size_t)p) & ~(sizeof_chunk-1));
}

static inline char *
markbyte(void **p)
{
  char *base = markbase(p);
  return base + ((p - (void**)base)>>1);
}

static block_t *
new_block(void)
{
  block_t *b = new block_t;
  memset(b, 0, sizeof(block_t));
  b->lo = (void**)markbase(b->ptrs+nptrs_chunk-1);
  b->hi = (void**)markbase(b->ptrs+nptrs_block);
  return b;
}

static void
clear_marks(block_t *b)
{
  for (void** m=b->lo; m<b->hi; m+=nptrs_chunk)
    m[0] = m[1] = 0;
}

static void
collect_free(block_t *b, void **&freelist, int &count, bool destroy)
{
  for (void **m=b->lo; m<b->hi; m+=nptrs_chunk)
    {
      char *c = (char*)m;
      for (unsigned int i=1; i<nptrs_chunk/2; i++)
        if (! c[i])
          {
            miniobj_t *obj = (miniobj_t*)m[i+i];
            if (destroy && obj && m[i+i]==m[i+i+1]) 
              obj->destroy();
            m[i+i] = (void*)freelist;
            m[i+i+1] = 0;
            freelist = &m[i+i];
            count += 1;
          }
    }
}

static void
new_pair_block(void)
{
  int count = 0;
  block_t *b = new_block();
  b->next = gc.pairs_blocks;
  gc.pairs_blocks = b;
  clear_marks(b);
  collect_free(b, gc.pairs_freelist, count, false);
  gc.pairs_total += count;
  gc.pairs_free += count;
}

static void
new_obj_block(void)
{
  int count = 0;
  block_t *b = new_block();
  b->next = gc.objs_blocks;
  gc.objs_blocks = b;
  clear_marks(b);
  collect_free(b, gc.objs_freelist, count, false);
  gc.objs_total += count;
  gc.objs_free += count;
}

#if defined(__GNUC__) && (__GNUC__ >= 3)
static void gc_mark_object(void **v) __attribute__((noinline));
#else
static void gc_mark_object(void **v);
#endif

static bool
gc_mark_check(void *p)
{
  if (((size_t)p) & 2)
    return false;
  void **v = (void**)(((size_t)p) & ~(size_t)3); 
  if (! v)
    return false;
  char *m = markbyte(v);
  if (*m)
    return false;
  *m = 1;
  if (! (((size_t)p) & 1))
    return true;
  gc_mark_object((void**)v);
  return false;
}

static void
gc_mark_pair(void **v)
{
  // This is a simple recursive code.
  // Despite the tail recursion for the cdrs,
  // it consume a stack space that grows like
  // the longest chain of cars.
  for(;;)
    {
      if (gc_mark_check(v[0]))
        gc_mark_pair((void**)v[0]);
      if (! gc_mark_check(v[1]))
        break;
      v = (void**)v[1];
    }
}

static void
gc_mark(miniexp_t *pp)
{
  void **v = (void**)*pp;
  if (gc_mark_check((void**)*pp))
    gc_mark_pair(v);
}

static void
gc_mark_object(void **v)
{
  ASSERT(v[0] == v[1]);
  miniobj_t *obj = (miniobj_t*)v[0];
  if (obj) 
    obj->mark(gc_mark);
}

static void
gc_run(void)
{
  gc.request++;
  if (gc.lock == 0)
    {
      block_t *b;
      gc.request = 0;
      // clear marks
      for (b=gc.objs_blocks; b; b=b->next)
        clear_marks(b);
      for (b=gc.pairs_blocks; b; b=b->next)
        clear_marks(b);
      // mark recents
      for (gctls_t *tls = gc.tls; tls; tls=tls->next)
        for (int i=0; i<recentsize; i++)
          gc_mark((miniexp_t*)(char*)&(tls->recent[i]));
      // mark roots
      minivar_t::mark(gc_mark);
      // sweep
      gc.objs_free = gc.pairs_free = 0;
      gc.objs_freelist = gc.pairs_freelist = 0;
      for (b=gc.objs_blocks; b; b=b->next)
        collect_free(b, gc.objs_freelist, gc.objs_free, true);
      for (b=gc.pairs_blocks; b; b=b->next)
        collect_free(b, gc.pairs_freelist, gc.pairs_free, false);
      // alloc 33% extra space
      while (gc.objs_free*4 < gc.objs_total)
        new_obj_block();
      while (gc.pairs_free*4 < gc.pairs_total)
        new_pair_block();
    }
}

static void **
gc_alloc_pair(void *a, void *d)
{
  if (!gc.pairs_freelist)
    {
      gc_run();
      if (!gc.pairs_freelist)
        new_pair_block();
    }
  else if (gc.debug)
    gc_run();
  void **p = gc.pairs_freelist;
  gc.pairs_freelist = (void**)p[0];
  gc.pairs_free -= 1;
  p[0] = a;
  p[1] = d;
  return p;
}

static void **
gc_alloc_object(void *obj)
{
  if (!gc.objs_freelist)
    {
      gc_run();
      if (!gc.objs_freelist)
        new_obj_block();
    }
  else if (gc.debug)
    gc_run();
  void **p = gc.objs_freelist;
  gc.objs_freelist = (void**)p[0];
  gc.objs_free -= 1;
  p[0] = p[1] = obj;
  return p;
}





/* ---- USER FUNCTIONS --- */

miniexp_t
minilisp_acquire_gc_lock(miniexp_t x)
{
  CSLOCK(locker);
  gc.lock++;
  return x;
}

miniexp_t
minilisp_release_gc_lock(miniexp_t x)
{
  minivar_t v = x;
  {
    CSLOCK(locker);
    if (gc.lock > 0)
      if (--gc.lock == 0)
        if (gc.request > 0)
          gc_run();
  }
  return x;
}

void 
minilisp_gc(void)
{
  CSLOCK(locker);
  for (gctls_t *tls = gc.tls; tls; tls=tls->next)
    for (int i=0; i<recentsize; i++)
      tls->recent[i] = 0;
  gc_run();
}

void 
minilisp_debug(int debug)
{
  gc.debug = debug;
}

void 
minilisp_info(void)
{
  CSLOCK(locker);
  time_t tim = time(0);
  const char *dat = ctime(&tim);
  printf("--- begin info -- %s", dat);
  printf("symbols: %d symbols in %d buckets\n", 
         symbols->nelems, symbols->nbuckets);
  if (gc.debug)
    printf("gc.debug: true\n");
  if (gc.lock)
    printf("gc.locked: true, %d requests\n", gc.request);
  printf("gc.pairs: %d free, %d total\n", gc.pairs_free, gc.pairs_total);
  printf("gc.objects: %d free, %d total\n", gc.objs_free, gc.objs_total);
  printf("--- end info -- %s", dat);
}

miniexp_t
miniexp_mutate(miniexp_t, miniexp_t *var, miniexp_t val)
{
  CSLOCK(locker);
  *var = val;
  return val;
}


/* -------------------------------------------------- */
/* MINIVARS                                           */
/* -------------------------------------------------- */

minivar_t::minivar_t()
  : data(0)
{
  CSLOCK(locker);
  if ((next = vars))
    next->pprev = &next;
  pprev = &vars;
  vars = this;
}

minivar_t::minivar_t(miniexp_t p)
  : data(p)
{
  CSLOCK(locker);
  if ((next = vars))
    next->pprev = &next;
  pprev = &vars;
  vars = this;
}

minivar_t::minivar_t(const minivar_t &v)
  : data(v.data)
{
  CSLOCK(locker);
  if ((next = vars))
    next->pprev = &next;
  pprev = &vars;
  vars = this;
}

minivar_t::~minivar_t()
{ 
  CSLOCK(locker);
  if ((*pprev = next)) 
    next->pprev = pprev; 
}

minivar_t *minivar_t::vars = 0;

void
minivar_t::mark(minilisp_mark_t *f)
{
  for (minivar_t *v = vars; v; v=v->next)
    (*f)(&v->data);
}

minivar_t *
minivar_alloc(void)
{
  return new minivar_t;
}

void 
minivar_free(minivar_t *v)
{
  delete v;
}

miniexp_t *
minivar_pointer(minivar_t *v)
{
  return &(*v);
}


/* -------------------------------------------------- */
/* LISTS                                              */
/* -------------------------------------------------- */

static inline miniexp_t &
car(miniexp_t p) {
  return ((miniexp_t*)p)[0];
}

static inline miniexp_t &
cdr(miniexp_t p) {
  return ((miniexp_t*)p)[1];
}

int 
miniexp_length(miniexp_t p)
{
  int n = 0;
  bool toggle = false;
  miniexp_t q = p;
  while (miniexp_consp(p))
    {
      p = cdr(p);
      if (p == q)
        return -1;
      if ((toggle = !toggle))
        q = cdr(q);
      n += 1;
    }
  return n;
}

miniexp_t 
miniexp_caar(miniexp_t p)
{
  return miniexp_car(miniexp_car(p)); 
}

miniexp_t 
miniexp_cadr(miniexp_t p)
{
  return miniexp_car(miniexp_cdr(p)); 
}

miniexp_t 
miniexp_cdar(miniexp_t p)
{
  return miniexp_cdr(miniexp_car(p)); 
}

miniexp_t 
miniexp_cddr(miniexp_t p)
{
  return miniexp_cdr(miniexp_cdr(p)); 
}

miniexp_t 
miniexp_caddr(miniexp_t p)
{
  return miniexp_car(miniexp_cdr(miniexp_cdr(p)));
}

miniexp_t 
miniexp_cdddr(miniexp_t p)
{
  return miniexp_cdr(miniexp_cdr(miniexp_cdr(p)));
}

miniexp_t 
miniexp_nth(int n, miniexp_t l)
{
  while (--n>=0 && miniexp_consp(l)) 
    l = cdr(l);
  return miniexp_car(l);
}

miniexp_t 
miniexp_cons(miniexp_t a, miniexp_t d)
{
  CSLOCK(locker);
  miniexp_t r = (miniexp_t)gc_alloc_pair((void*)a, (void*)d); 
  gctls_t *tls = gctls();
  tls->recent[(++(tls->recentindex)) & (recentsize-1)] = (void**)r;
  return r;
}

miniexp_t 
miniexp_rplaca(miniexp_t pair, miniexp_t newcar)
{
  if (miniexp_consp(pair))
    return miniexp_mutate(pair, &car(pair), newcar);
  return 0;
}

miniexp_t 
miniexp_rplacd(miniexp_t pair, miniexp_t newcdr)
{
  if (miniexp_consp(pair))
    return miniexp_mutate(pair, &cdr(pair), newcdr);
  return 0;
}

miniexp_t 
miniexp_reverse(miniexp_t p)
{
  miniexp_t l = 0;
  while (miniexp_consp(p))
    {
      miniexp_t q = cdr(p);
      miniexp_mutate(p, &cdr(p), l);
      l = p;
      p = q;
    }
  return l;
}


/* -------------------------------------------------- */
/* MINIOBJ                                            */
/* -------------------------------------------------- */

miniobj_t::~miniobj_t()
{
}

const miniexp_t miniobj_t::classname = 0;

bool
miniobj_t::isa(miniexp_t) const
{
  return false;
}

void 
miniobj_t::mark(minilisp_mark_t*)
{
}

void 
miniobj_t::destroy()
{
  delete this;
}

char *
miniobj_t::pname() const
{
  const char *cname = miniexp_to_name(classof());
  char *res = new char[strlen(cname)+24];
  sprintf(res,"#%s:<%p>",cname,this);
  return res;
}

miniexp_t 
miniexp_object(miniobj_t *obj)
{
  CSLOCK(locker);
  void **v = gc_alloc_object((void*)obj);
  v = (void**)(((size_t)v)|((size_t)1));
  gctls_t *tls = gctls();
  tls->recent[(++(tls->recentindex)) & (recentsize-1)] = (void**)v;
  return (miniexp_t)(v);
}

miniexp_t 
miniexp_classof(miniexp_t p) 
{
  miniobj_t *obj = miniexp_to_obj(p);
  if (obj) return obj->classof();
  return miniexp_nil;
}

miniexp_t 
miniexp_isa(miniexp_t p, miniexp_t c)
{
  miniobj_t *obj = miniexp_to_obj(p);
  if (obj && obj->isa(c))
    return obj->classof();
  return miniexp_nil;
}


/* -------------------------------------------------- */
/* STRINGS                                            */
/* -------------------------------------------------- */

BEGIN_ANONYMOUS_NAMESPACE

class ministring_t : public miniobj_t 
{
  MINIOBJ_DECLARE(ministring_t,miniobj_t,"string");
public:
  ~ministring_t();
  ministring_t(const char *s);
  ministring_t(char *s, bool steal);
  operator const char*() const { return s; }
  virtual char *pname() const;
private:
  char *s;
private:
  ministring_t(const ministring_t &);
  ministring_t& operator=(const ministring_t &);
};

MINIOBJ_IMPLEMENT(ministring_t,miniobj_t,"string");

ministring_t::~ministring_t()
{
  delete [] s;
}

ministring_t::ministring_t(const char *str) 
  : s(new char[strlen(str)+1])
{
  strcpy(s,str);
}

ministring_t::ministring_t(char *str, bool steal) 
  : s(str)
{
  ASSERT(steal);
}

END_ANONYMOUS_NAMESPACE

static bool
char_quoted(int c, int flags)
{
  bool print7bits = (flags & miniexp_io_print7bits);
  if (c>=0x80 && !print7bits)
    return false;
  if (c==0x7f || c=='\"' || c=='\\')
    return true;
  if (c>=0x20 && c<0x7f)
    return false;
  return true;
}

static bool
char_utf8(int &c, const char* &s)
{
  if (c < 0xc0)
    return (c < 0x80);
  if (c >= 0xf8)
    return false;
  int n = (c < 0xe0) ? 1 : (c < 0xf0) ? 2 : 3;
  int x = c & (0x3f >> n);
  for (int i=0; i<n; i++)
    if ((s[i] & 0xc0) == 0x80)
      x = (x << 6) + (s[i] & 0x3f);
    else
      return false;
  static int lim[] = {0, 0x80, 0x800, 0x10000};
  if (x < lim[n])
    return false;
  if (x > 0x10ffff)
    return false;
  if (x >= 0xd800 && x <= 0xdfff)
    return false;
  s += n;
  c = x;
  return true;
}

static void
char_out(int c, char* &d, int &n)
{
  n++;
  if (d) 
    *d++ = c;
}

static int
print_c_string(const char *s, char *d, int flags = 0)
{
  int c;
  int n = 0;
  char_out('\"', d, n);
  while ((c = (unsigned char)(*s++)))
    {
      if (char_quoted(c, flags))
        {
          char buffer[10];
          static const char *tr1 = "\"\\tnrbf";
          static const char *tr2 = "\"\\\t\n\r\b\f";
          buffer[0] = buffer[1] = 0;
          char_out('\\', d, n);
          for (int i=0; tr2[i]; i++)
            if (c == tr2[i])
              buffer[0] = tr1[i];
          if (buffer[0] == 0 && c >= 0x80 
              && (flags & (miniexp_io_u4escape | miniexp_io_u6escape))
              && char_utf8(c, s) )
            {
              if (c <= 0xffff && (flags & miniexp_io_u4escape))
                sprintf(buffer,"u%04X", c);
              else if (flags & miniexp_io_u6escape) // c# style
                sprintf(buffer,"U%06X", c);
              else if (flags & miniexp_io_u4escape) // json style
                sprintf(buffer,"u%04X\\u%04X", 
                        0xd800+(((c-0x10000)>>10)&0x3ff), 
                        0xdc00+(c&0x3ff));
            }
          if (buffer[0] == 0)
            sprintf(buffer, "%03o", c);
          for (int i=0; buffer[i]; i++)
            char_out(buffer[i], d, n);
          continue;
        }
      char_out(c, d, n);
    }
  char_out('\"', d, n);
  char_out(0, d, n);
  return n;
}

char *
ministring_t::pname() const
{
  int n = print_c_string(s, 0);
  char *d = new char[n];
  if (d) print_c_string(s, d);
  return d;
}

int 
miniexp_stringp(miniexp_t p)
{
  return miniexp_isa(p, ministring_t::classname) ? 1 : 0;
}

const char *
miniexp_to_str(miniexp_t p)
{
  miniobj_t *obj = miniexp_to_obj(p);
  if (miniexp_stringp(p))
    return (const char*) * (ministring_t*) obj;
  return 0;
}

miniexp_t 
miniexp_string(const char *s)
{
  ministring_t *obj = new ministring_t(s);
  return miniexp_object(obj);
}

miniexp_t 
miniexp_substring(const char *s, int n)
{
  int l = strlen(s);
  n = (n < l) ? n : l;
  char *b = new char[n+1];
  strncpy(b, s, n);
  b[n] = 0;
  ministring_t *obj = new ministring_t(b, true);
  return miniexp_object(obj);
}

miniexp_t 
miniexp_concat(miniexp_t p)
{
  miniexp_t l = p;
  const char *s;
  int n = 0;
  if (miniexp_length(l) < 0)
    return miniexp_nil;
  for (p=l; miniexp_consp(p); p=cdr(p))
    if ((s = miniexp_to_str(car(p))))
      n += strlen(s);
  char *b = new char[n+1];
  char *d = b;
  for (p=l; miniexp_consp(p); p=cdr(p))
    if ((s = miniexp_to_str(car(p)))) {
      strcpy(d, s);
      d += strlen(d);
    }
  ministring_t *obj = new ministring_t(b, true);
  return miniexp_object(obj);
}


/* -------------------------------------------------- */
/* FLOATNUMS                                          */
/* -------------------------------------------------- */


BEGIN_ANONYMOUS_NAMESPACE

class minifloat_t : public miniobj_t 
{
  MINIOBJ_DECLARE(minifloat_t,miniobj_t,"floatnum");
public:
  minifloat_t(double x) : val(x) {}
  operator double() const { return val; }
  virtual char *pname() const;
private:
  double val;
};


MINIOBJ_IMPLEMENT(minifloat_t,miniobj_t,"floatnum");

END_ANONYMOUS_NAMESPACE

int 
miniexp_floatnump(miniexp_t p)
{
  return miniexp_isa(p, minifloat_t::classname) ? 1 : 0;
}

miniexp_t 
miniexp_floatnum(double x)
{
  minifloat_t *obj = new minifloat_t(x);
  return miniexp_object(obj);
}

double 
miniexp_to_double(miniexp_t p)
{
  if (miniexp_numberp(p))
    return (double) miniexp_to_int(p);
  else if (miniexp_floatnump(p))
    return (double) * (minifloat_t*) miniexp_to_obj(p);
  return 0.0;
}

miniexp_t 
miniexp_double(double x)
{
  miniexp_t exp = miniexp_number((int)(x));
  if (x != (double)miniexp_to_int(exp))
    exp = miniexp_floatnum(x);
  return exp;
}

static bool
str_looks_like_double(const char *s)
{
  if (isdigit(s[0]))
    return true;
  if ((s[0] == '+' || s[0] == '-') && s[1])
    return true;
  return false;
}

char *
minifloat_t::pname() const
{
  char *r = new char[64];
  sprintf(r,"%f",val);
  if (! str_looks_like_double(r))
    sprintf(r,"+%f",val);
  return r;
}

static bool
str_is_double(const char *s, double &x)
{
  if (str_looks_like_double(s))
    {
      char *end;
      errno = 0;
      x = (double) strtol(s, &end, 0);
      if (*end == 0 && errno == 0) 
        return true;
      x = (double) strtod(s, &end);
      if (*end == 0 && errno == 0) 
        return true;
    }
  return false;
}



/* -------------------------------------------------- */
/* INPUT/OUTPUT                                       */
/* -------------------------------------------------- */

static int true_stdio_fputs(miniexp_io_t *io, const char *s) {
  FILE *f = (io->data[1]) ? (FILE*)(io->data[1]) : stdout;
  return ::fputs(s, f);
}
static int compat_puts(const char *s) { 
  return true_stdio_fputs(&miniexp_io, s); 
}
static int stdio_fputs(miniexp_io_t *io, const char *s) {
  if (io == &miniexp_io) 
    return (*minilisp_puts)(s);
  return true_stdio_fputs(io, s);
}

static int true_stdio_fgetc(miniexp_io_t *io) {
  FILE *f = (io->data[0]) ? (FILE*)(io->data[0]) : stdin;
  return ::getc(f);
}
static int compat_getc() { 
  return true_stdio_fgetc(&miniexp_io); 
}
static int stdio_fgetc(miniexp_io_t *io)
{
  if (io == &miniexp_io) 
    return (*minilisp_getc)();
  return true_stdio_fgetc(io);
}

static int true_stdio_ungetc(miniexp_io_t *io, int c) {
  FILE *f = (io->data[0]) ? (FILE*)(io->data[0]) : stdin;
  return ::ungetc(c, f);
}
static int compat_ungetc(int c) { 
  return true_stdio_ungetc(&miniexp_io, c); 
}
static int stdio_ungetc(miniexp_io_t *io, int c) {
  if (io == &miniexp_io) 
    return (*minilisp_ungetc)(c);
  return true_stdio_ungetc(io, c);
}

extern "C" 
{ 
  // SunCC needs this to be defined inside extern "C" { ... }
  // Beware the difference between extern "C" {...} and extern "C".
  miniexp_t (*minilisp_macrochar_parser[128])(void);
  miniexp_t (*minilisp_diezechar_parser[128])(void);
  minivar_t minilisp_macroqueue;
  int minilisp_print_7bits;
}

miniexp_io_t miniexp_io = { 
  stdio_fputs, stdio_fgetc, stdio_ungetc, { 0, 0, 0, 0 },
  (int*)&minilisp_print_7bits,
  (miniexp_macrochar_t*)minilisp_macrochar_parser, 
  (miniexp_macrochar_t*)minilisp_diezechar_parser, 
  (minivar_t*)&minilisp_macroqueue,
  0
};  

int (*minilisp_puts)(const char *) = compat_puts;
int (*minilisp_getc)(void) = compat_getc;
int (*minilisp_ungetc)(int) = compat_ungetc;

void 
miniexp_io_init(miniexp_io_t *io)
{
  io->fputs = stdio_fputs;
  io->fgetc = stdio_fgetc;
  io->ungetc = stdio_ungetc;
  io->data[0] = io->data[1] = io->data[2] = io->data[3] = 0;
  io->p_flags = (int*)&minilisp_print_7bits;;
  io->p_macrochar = (miniexp_macrochar_t*)minilisp_macrochar_parser;
  io->p_diezechar = (miniexp_macrochar_t*)minilisp_diezechar_parser;
  io->p_macroqueue = (minivar_t*)&minilisp_macroqueue;
  io->p_reserved = 0;
}

void 
miniexp_io_set_output(miniexp_io_t* io, FILE *f)
{
  io->fputs = stdio_fputs;
  io->data[1] = f;
}

void 
miniexp_io_set_input(miniexp_io_t* io, FILE *f)
{
  io->fgetc = stdio_fgetc;
  io->ungetc = stdio_ungetc;
  io->data[0] = f;
}


/* ---- OUTPUT */

BEGIN_ANONYMOUS_NAMESPACE

struct printer_t 
{
  int tab;
  bool dryrun;
  miniexp_io_t *io;
  printer_t(miniexp_io_t *io) : tab(0), dryrun(false), io(io) {}
  void mlput(const char *s);
  void mltab(int n);
  void print(miniexp_t p);
  bool must_quote_symbol(const char *s, int flags);
  void mlput_quoted_symbol(const char *s);
  virtual miniexp_t begin() { return miniexp_nil; }
  virtual bool newline() { return false; }
  virtual void end(miniexp_t) { }
  virtual ~printer_t() {};
};

void
printer_t::mlput(const char *s)
{
  if (! dryrun)
    io->fputs(io, s);
  while (*s)
    if (*s++ == '\n')
      tab = 0;
    else
      tab += 1;
}

void
printer_t::mltab(int n)
{
  while (tab+8 <= n)
    mlput("        ");
  while (tab+1 <= n)
    mlput(" ");
}

bool
printer_t::must_quote_symbol(const char *s, int flags)
{
  int c;
  const char *r = s;
  while ((c = *r++))
    if (c=='(' || c==')' || c=='\"' || c=='|' || 
        isspace(c) || !isascii(c) || !isprint(c) ||
        (c >= 0 && c < 128 && io->p_macrochar && io->p_macrochar[c]) )
      return true;
  double x;
  if (flags & miniexp_io_quotemoresymbols)
    return str_looks_like_double(s);
  return str_is_double(s, x);
}

void
printer_t::mlput_quoted_symbol(const char *s)
{
  int l = strlen(s);
  char *r = new char[l+l+3];
  char *z = r;
  *z++ = '|';
  while (*s)
    if ((*z++ = *s++) == '|')
      *z++ = '|';
  *z++ = '|';
  *z++ = 0;
  mlput(r);
  delete [] r;
}

void
printer_t::print(miniexp_t p)
{
  int flags = (io->p_flags) ? *io->p_flags : 0;
  static char buffer[32];
  miniexp_t b = begin();
  if (p == miniexp_nil)
    {
      mlput("()");
    }
  else if (miniexp_numberp(p))
    {
      sprintf(buffer, "%d", miniexp_to_int(p));
      mlput(buffer);
    }
  else if (miniexp_symbolp(p))
    {
      const char *s = miniexp_to_name(p);
      if (must_quote_symbol(s, flags))
        mlput_quoted_symbol(s);
      else
        mlput(s);
    }
  else if (miniexp_stringp(p))
    {
      const char *s = miniexp_to_str(p);
      int n = print_c_string(s, 0, flags);
      char *d = new char[n];
      if (d) 
        print_c_string(s, d, flags);
      mlput(d);
      delete [] d;
    }
  else if (miniexp_objectp(p))
    {
      miniobj_t *obj = miniexp_to_obj(p);
      char *s = obj->pname();
      mlput(s);
      delete [] s;
    }
  else if (miniexp_listp(p))
    {
      // TODO - detect more circular structures
      int skip = 1;
      int indent = tab + 1;
      bool multiline = false;
      bool toggle = true;
      miniexp_t q = p;
      mlput("(");
      if (miniexp_consp(p) && miniexp_symbolp(car(p)))
        {
          skip++;
          indent++;
        }
      while (miniexp_consp(p))
        {
          skip -= 1;
	  if (multiline || (newline() && skip<0 && tab>indent))
            {
              mlput("\n"); 
              mltab(indent); 
              multiline=true; 
            }
          print(car(p));
          if ((p = cdr(p)))
            mlput(" ");
          if ((toggle = !toggle))
            q = cdr(q);
          if (p == q)
            {
              mlput("...");
              p = 0;
            }
        }
      if (p)
        {
          skip -= 1;
	  if (multiline || (newline() && skip<0 && tab>indent))
            {
              mlput("\n"); 
              mltab(indent); 
              multiline=true; 
            }
          mlput(". ");
          print(p);
        }
      if (multiline)
        mlput(" )");
      else
        mlput(")");
    }
  end(b);
}

struct pprinter_t : public printer_t 
{
  int width;
  minivar_t l;
  pprinter_t(miniexp_io_t *io) : printer_t(io) {}
  virtual miniexp_t begin();
  virtual bool newline();
  virtual void end(miniexp_t);
};

miniexp_t 
pprinter_t::begin()
{
  if (dryrun)
    {
      l = miniexp_cons(miniexp_number(tab), l);
      return l;
    }
  else
    {
      ASSERT(miniexp_consp(l));
      ASSERT(miniexp_numberp(car(l)));
      l = cdr(l);
      return miniexp_nil;
    }
}

bool 
pprinter_t::newline()
{
  if (! dryrun)
    {
      ASSERT(miniexp_consp(l));
      ASSERT(miniexp_numberp(car(l)));
      int len = miniexp_to_int(car(l));
      if (tab + len >= width)
        return true;
    }
  return false;
}

void 
pprinter_t::end(miniexp_t p)
{
  if (dryrun)
    {
      ASSERT(miniexp_consp(p));
      ASSERT(miniexp_numberp(car(p)));
      int pos = miniexp_to_int(car(p));
      ASSERT(tab >= pos);
      miniexp_rplaca(p, miniexp_number(tab - pos));
    }
}

END_ANONYMOUS_NAMESPACE

miniexp_t 
miniexp_prin_r(miniexp_io_t *io, miniexp_t p)
{
  minivar_t xp = p;
  printer_t printer(io);
  printer.print(p);
  return p;
}

miniexp_t 
miniexp_print_r(miniexp_io_t *io, miniexp_t p)
{
  minivar_t xp = p;
  miniexp_prin_r(io, p);
  io->fputs(io, "\n");
  return p;
}

miniexp_t 
miniexp_pprin_r(miniexp_io_t *io, miniexp_t p, int width)
{  
  minivar_t xp = p;
  pprinter_t printer(io);
  printer.width = width;
  // step1 - measure lengths into list <l>
  printer.tab = 0;
  printer.dryrun = true;
  printer.print(p);
  // step2 - print
  printer.tab = 0;
  printer.dryrun = false;
  printer.l = miniexp_reverse(printer.l);
  printer.print(p);
  // check
  ASSERT(printer.l == 0);
  return p;
}

miniexp_t 
miniexp_pprint_r(miniexp_io_t *io, miniexp_t p, int width)
{
  miniexp_pprin_r(io, p, width);
  io->fputs(io, "\n");
  return p;
}


/* ---- PNAME */

static int
pname_fputs(miniexp_io_t *io, const char *s)
{
  char *b = (char*)(io->data[0]);
  size_t l = (size_t)(io->data[2]);
  size_t m = (size_t)(io->data[3]);
  size_t x = strlen(s);
  if (l + x >= m)
    {
      size_t nm = l + x + 256;
      char *nb = new char[nm+1];
      memcpy(nb, b, l);
      delete [] b;
      b = nb;
      m = nm;
    }
  strcpy(b + l, s);
  io->data[0] = (void*)(b);
  io->data[2] = (void*)(l + x);
  io->data[3] = (void*)(m);
  return x;
}

miniexp_t 
miniexp_pname(miniexp_t p, int width)
{
  minivar_t r;
  miniexp_io_t io;
  miniexp_io_init(&io);
  io.fputs = pname_fputs;
  io.data[0] = io.data[2] = io.data[3] = 0;
  try
    {
      if (width > 0)
        miniexp_pprin_r(&io, p, width);
      else
        miniexp_prin_r(&io, p);
      if (io.data[0])
        r = miniexp_string((const char*)io.data[0]);
      delete [] (char*)(io.data[0]);
    }
  catch(...)
    {
      delete [] (char*)(io.data[0]);
    }
  return r;
}


/* ---- INPUT */

static void
grow(char* &s, int &l, int &m)
{
  int nm = ((m<256)?256:m) + ((m>32000)?32000:m);
  char *ns = new char[nm+1];
  memcpy(ns, s, l);
  delete [] s;
  m = nm;
  s = ns;
}

static void
append(int c, char* &s, int &l, int &m)
{
  if (l >= m)
    grow(s, l, m);
  s[l++] = c;
  s[l] = 0;
}

static void
append_utf8(int x, char *&s, int &l, int &m)
{
  if (x >= 0 && x <= 0x10ffff)
    { 
      if (l + 4 >= m)
        grow(s, l, m);
      if (x <= 0x7f) {
        s[l++] = (char)x;
      } else if (x <= 0x7ff) {
        s[l++] = (char)((x>>6)|0xc0);
        s[l++] = (char)((x|0x80)&0xbf);
      } else if (x <= 0xffff) {
        s[l++] = (char)((x>>12)|0xe0);
        s[l++] = (char)(((x>>6)|0x80)&0xbf);
        s[l++] = (char)((x|0x80)&0xbf);
      } else {
        s[l++] = (char)((x>>18)|0xf0);
        s[l++] = (char)(((x>>12)|0x80)&0xbf);
        s[l++] = (char)(((x>>6)|0x80)&0xbf);
        s[l++] = (char)((x|0x80)&0xbf);
      }
      s[l] = 0;
    }
}

static void
skip_blank(miniexp_io_t *io, int &c)
{
  while (isspace(c))
    c = io->fgetc(io);
}

static void
skip_newline(miniexp_io_t *io, int &c)
{
  int d = c;
  if (c == '\n' || c == '\r')
    c = io->fgetc(io);
  if ((c == '\n' || c == '\r') && (c != d))
    c = io->fgetc(io);
}

static int
skip_octal(miniexp_io_t *io, int &c, int maxlen=3)
{
  int n = 0;
  int x = 0;
  while (c >= '0' && c < '8' && n++ < maxlen)
    {
      x = (x<<3) + c - '0';
      c = io->fgetc(io);
    }
  return x;
}

static int
skip_hexadecimal(miniexp_io_t *io, int &c, int maxlen=2)
{
  int n = 0;
  int x = 0;
  while (isxdigit(c) && n++ < maxlen && x <= 0x10fff) // unicode range only
    {
      x = (x<<4) + (isdigit(c) ? c-'0' : toupper(c)-'A'+10);
      c = io->fgetc(io);
    }
  return x;
}

static miniexp_t
read_error(miniexp_io_t *io, int &c)
{
  while (c!=EOF && c!='\n')
    c = io->fgetc(io);
  return miniexp_dummy;
}

static miniexp_t
read_c_string(miniexp_io_t *io, int &c)
{
  miniexp_t r;
  char *s = 0;
  int l = 0;
  int m = 0;
  ASSERT(c == '\"');
  c = io->fgetc(io);
  for(;;)
    {
      if (c==EOF || (isascii(c) && !isprint(c)))
        return read_error(io, c);
      else if (c=='\"')
        break;
      else if (c=='\\')
        {
          c = io->fgetc(io);
          if (c == '\n' || c == '\r')
            {
              skip_newline(io, c);
              continue;
            }
          else if (c>='0' && c<='7')
            {
              int x = skip_octal(io, c, 3);
              append((char)x, s, l, m);
              continue;
            }
          else if (c=='x' || c=='X')
            {
              int d = c;
              c = io->fgetc(io);
              if (isxdigit(c))
                {
                  int x = skip_hexadecimal(io, c, 2);
                  append((char)x, s, l, m);
                  continue;
                }
              io->ungetc(io, c);
              c = d;
            }
          else if (c == 'u' || c == 'U')
            {
              int x = -1;
              int d = c;
              c = io->fgetc(io);
              if (isxdigit(c))
                x = skip_hexadecimal(io, c, isupper(d) ? 6 : 4);
              while (x >= 0xd800 && x <= 0xdbff && c == '\\')
                {
                  c = io->fgetc(io);
                  if (c != 'u' && c != 'U') 
                    {
                      io->ungetc(io, c);
                      c = '\\';
                      break;
                    }
                  d = c;
                  c = io->fgetc(io);
                  int z = -1;
                  if (isxdigit(c))
                    z = skip_hexadecimal(io, c, isupper(d) ? 6 : 4);
                  if (z >= 0xdc00 && z <= 0xdfff)
                    {
                      x = 0x10000 + ((x & 0x3ff) << 10) + (z & 0x3ff);
                      break;
                    }
                  append_utf8(x, s, l, m);
                  x = z;
                }
              if (x >= 0)
                {
                  append_utf8(x, s, l, m);
                  continue;
                }
              io->ungetc(io, c);
              c = d;
            }
          static const char *tr1 = "tnrbfva";
          static const char *tr2 = "\t\n\r\b\f\013\007";
          for (int i=0; tr1[i]; i++)
            if (c == tr1[i])
              c = tr2[i];
        }
      append(c,s,l,m);
      c = io->fgetc(io);
    }
  c = io->fgetc(io);
  r = miniexp_string(s ? s : "");
  delete [] s;
  return r;
}

static miniexp_t
read_quoted_symbol(miniexp_io_t *io, int &c)
{
  miniexp_t r;
  char *s = 0;
  int l = 0;
  int m = 0;
  ASSERT(c == '|');
  for(;;)
    {
      c = io->fgetc(io);
      if (c==EOF || (isascii(c) && !isprint(c)))
        return read_error(io, c);
      if (c=='|')
        if ((c = io->fgetc(io)) != '|')
          break;
      append(c,s,l,m);
    }
  r = miniexp_symbol(s ? s : "");
  delete [] s;
  return r;
}

static miniexp_t
read_symbol_or_number(miniexp_io_t *io, int &c)
{
  miniexp_t r;
  char *s = 0;
  int l = 0;
  int m = 0;
  for(;;)
    {
      if (c==EOF || c=='(' || c==')' || c=='|' || c=='\"'  
          || isspace(c) || !isascii(c) || !isprint(c) 
          || (io->p_macrochar && io->p_macroqueue  
              && c < 128 && c >= 0 && io->p_macrochar[c] ) )
        break;
      append(c,s,l,m);
      c = io->fgetc(io);
    }
  if (l <= 0)
    return read_error(io, c);
  double x;
  if (str_is_double(s, x))
    r = miniexp_double(x);
  else
    r = miniexp_symbol(s);
  delete [] s;
  return r;
}

static miniexp_t
read_miniexp(miniexp_io_t *io, int &c)
{
  for(;;)
    {
      if (io->p_macroqueue && miniexp_consp(*io->p_macroqueue))
        {
          miniexp_t p = car(*io->p_macroqueue);
          *io->p_macroqueue = cdr(*io->p_macroqueue);
          return p;
        }
      skip_blank(io, c);
      if (c == EOF)
        {
          // clean end-of-file.
          return miniexp_dummy;
        }
      else if (c == ')')
        {
          c = io->fgetc(io);
          continue;
        }
      else if (c == '(')
        {
          minivar_t l = miniexp_cons(miniexp_nil, miniexp_nil);
          miniexp_t tail = l;
          minivar_t p;
          c = io->fgetc(io);
          for(;;)
            {
              skip_blank(io, c);
              if (c == ')')
                break;
              if (c == '.')
                {
                  int d = io->fgetc(io);
                  io->ungetc(io, d);
                  if (isspace(d)) 
                    break;
                }
              p = read_miniexp(io, c);
              if ((miniexp_t)p == miniexp_dummy)
                return read_error(io, c);
              p = miniexp_cons(p, miniexp_nil);
              miniexp_rplacd(tail, p);
              tail = p;
            }
          if (c == '.')
            {
              c = io->fgetc(io);
              skip_blank(io, c);
              if (c != ')')
                miniexp_rplacd(tail, read_miniexp(io, c));
            }
          skip_blank(io, c);
          if (c != ')')
            return read_error(io, c);
          c = io->fgetc(io);
          return cdr(l);
        }
      else if (c == '"')
        {
          return read_c_string(io, c);
        }
      else if (c == '|')
        {
          return read_quoted_symbol(io, c);
        }
      else if (io->p_macrochar && io->p_macroqueue 
               && c >= 0 && c < 128 && io->p_macrochar[c])
        {
          miniexp_t p = io->p_macrochar[c](io);
          if (miniexp_length(p) > 0)
            *io->p_macroqueue = p;
          else if (p)
            return read_error(io, c);
          c = io->fgetc(io);
          continue;
        }
      else if (c == '#')
        {
          int nc = io->fgetc(io);
          if (io->p_diezechar && io->p_macroqueue
              && nc >= 0 && nc < 128 && io->p_diezechar[nc])
            {
              miniexp_t p = io->p_macrochar[nc](io);
              if (miniexp_length(p) > 0)
                *io->p_macroqueue = p;
              else if (p)
                return read_error(io, c);
              c = io->fgetc(io);
              continue;
            }
          else if (nc == '#')
            return read_error(io, c);
          io->ungetc(io, nc);
          // fall thru
        }
      // default
      return read_symbol_or_number(io, c);
    }
}

miniexp_t 
miniexp_read_r(miniexp_io_t *io)
{
  int c = io->fgetc(io);
  miniexp_t p = read_miniexp(io, c);
  if (c != EOF)
    io->ungetc(io, c);
  return p;
}


/* ---- COMPAT */

miniexp_t miniexp_read(void)
{
  return miniexp_read_r(&miniexp_io);
}

miniexp_t miniexp_prin(miniexp_t p)
{
  return miniexp_prin_r(&miniexp_io, p);
}

miniexp_t miniexp_print(miniexp_t p)
{
  return miniexp_print_r(&miniexp_io, p);
}

miniexp_t miniexp_pprin(miniexp_t p, int w)
{
  return miniexp_pprin_r(&miniexp_io, p, w);
}

miniexp_t miniexp_pprint(miniexp_t p, int w)
{
  return miniexp_pprint_r(&miniexp_io, p, w);
}

void 
minilisp_set_output(FILE *f)
{
  minilisp_puts = compat_puts;
  miniexp_io_set_output(&miniexp_io, f);
}

void 
minilisp_set_input(FILE *f)
{
  minilisp_getc = compat_getc;
  minilisp_ungetc = compat_ungetc;
  miniexp_io_set_input(&miniexp_io, f);
}




/* -------------------------------------------------- */
/* CLEANUP (SEE GC ABOVE)                             */
/* -------------------------------------------------- */

static void
gc_clear(miniexp_t *pp)
{
  *pp = 0;
}

void
minilisp_finish(void)
{
  CSLOCK(locker);
  ASSERT(!gc.lock);
  // clear minivars
  minivar_t::mark(gc_clear);
  for (gctls_t *tls = gc.tls; tls; tls=tls->next)
    for (int i=0; i<recentsize; i++)
      tls->recent[i] = 0;
  // collect everything
  gc_run();
  // deallocate everything
  ASSERT(gc.pairs_free == gc.pairs_total);
  while (gc.pairs_blocks)
    {
      block_t *b = gc.pairs_blocks;
      gc.pairs_blocks = b->next;
      delete b;
    }
  ASSERT(gc.objs_free == gc.objs_total);
  while (gc.objs_blocks)
    {
      block_t *b = gc.objs_blocks;
      gc.objs_blocks = b->next;
      delete b;
    }
  delete symbols;
  symbols = 0;
}