/* -*- Mode: C; -*-
 * ------------------------------------------------------------------------------------------
 *     Title: Primitive Toy Lisp
 *   Created: Somewhen 2013
 *    Author: Gilbert Baumann <gilbert@bauhh.de> 
 * ------------------------------------------------------------------------------------------
 *  (c) copyright 2013-2020 by Gilbert Baumann
 */

/* THIS IS NOT FREE SOFTWARE AND NOT FOR REDISTRIBUTION. */

#define USE_READLINE 1

#include <stdio.h>
#include <string.h>
#include <math.h>
#include <stdlib.h>
#include <ctype.h>
#include <setjmp.h>
#include <stdint.h>
#include <gc.h>

#if USE_READLINE
#include <readline/readline.h>
#include <readline/history.h>
#endif

#define error my_error

/* -- Nodes -------------------------------------------------------------------------------- */

#define TYPE_CONS       0
#define TYPE_SYMBOL     1
#define TYPE_NUMBER     2
#define TYPE_STRING     3

typedef unsigned char type_t;

/*
 * We might want to encapsulate the T type in a structure, for added
 * type safety. Surprisingly this turns to slower code, so it is not
 * enabled by default.
 */
#define ENCAPSULATE_NODE 0

#if ENCAPSULATE_NODE
struct T {
  struct node *n;
};

typedef struct T T;             /* for extra type safety */
#define NODE(x) ((x).n)
T NIL = { 0 };
#else
typedef struct node *T;
#define NODE(x) (x)
#define NIL 0
#endif

struct node {
  type_t type;

  union {
    struct cons {
      T car;
      T cdr;
    } cons;

    struct symbol {
      T function;
      T more;                   /* (value name .  plist) */
    } symbol;

    struct number {
      double val;
    } number;

    struct string {
      char *string;
    } string;
  } u;
};

/* -- Forward Declarations ----------------------------------------------------------------- */

void error (const char *msg, T x) __attribute__((noreturn));
int null (T object);
double get_num (T object);
T prin1 (T, T);
T terpri (T);
T mk_string (char *string);

T unbound;

T fsubr_progn (T form, T env);

int eq (T x, T y);

T dot, rparen, tag_marker, block_marker;

T NIL_plist = NIL;
T oblist = NIL;

T sFIN;

#define SYMBOLS                                 \
  _(sT, "T")                                    \
  _(sCLOSURE, "CLOSURE")                        \
  _(sLAMBDA, "LAMBDA")                          \
  _(sMACRO, "MACRO")                            \
  _(sFSUBR, "FSUBR")                            \
  _(sSUBR, "SUBR")                              \
  _(sQUOTE, "QUOTE")                            \
  _(sFUNCTION, "FUNCTION")                      \
  _(kSTREAM, ":STREAM")                         \
  _(aOPTIONAL, "&OPTIONAL")                     \
  _(sBACKQUOTE, "BACKQUOTE")                    \
  _(sCOMMA, "COMMA")                            \
  _(sCOMMA_AT, "COMMA-AT")

#define FSUBRS                                  \
_(fsubr_progn, "PROGN")                         \
_(fsubr_function, "FUNCTION")                   \
_(fsubr_quote, "QUOTE")                         \
_(fsubr_if, "IF")                               \
_(fsubr_setq, "SETQ")                           \
_(fsubr_block, "BLOCK")                         \
_(fsubr_return_from, "RETURN-FROM")             \
_(fsubr_tagbody, "TAGBODY")                     \
_(fsubr_go, "GO")

#define _(fun,name) T fun (/*T, T*/);
FSUBRS
#undef _

T (*fsubr_table []) (T form, T env) = {
#define _(fun,name) fun,
  FSUBRS
#undef _
  0
};

#define _(var,name) T var;
SYMBOLS
#undef _

/* -- Nodes -------------------------------------------------------------------------------- */

T alloc_node (type_t type)
{
#if !ENCAPSULATE_NODE
  T res = GC_malloc (sizeof (struct node));
#else
  T res;
  res.n = GC_malloc (sizeof (struct node));
#endif
  NODE(res)->type = type;
  return res;
}

type_t type_of (T object)
{
  if (null (object))
    return TYPE_SYMBOL;
  else
    return NODE(object)->type;
}

int typep (T object, type_t type)
{
  return type_of (object) == type;
}

/* -- Conses ------------------------------------------------------------------------------- */

T cons (T ca, T cd)
{
  T res = alloc_node (TYPE_CONS);
  NODE(res)->u.cons.car = ca;
  NODE(res)->u.cons.cdr = cd;
  return res;
}

int consp (T object)
{
  return typep (object, TYPE_CONS);
}

T car (T x)
{
  if (null (x))
    return NIL;
  else if (consp (x))
    return NODE(x)->u.cons.car;
  else
    error ("Not a list", x);
}

T cdr (T x)
{
  if (null (x))
    return NIL;
  else if (consp (x))
    return NODE(x)->u.cons.cdr;
  else
    error ("Not a list", x);
}

T caar (T x) { return car (car (x)); }
T cadr (T x) { return car (cdr (x)); }
T cdar (T x) { return cdr (car (x)); }
T cddr (T x) { return cdr (cdr (x)); }

T caddr (T x) { return car (cdr (cdr (x))); }

T rplaca (T cell, T value)
{
  if (!consp (cell))
    error ("Not a cons cell", cell);
  NODE(cell)->u.cons.car = value;
  return cell;
}

T rplacd (T cell, T value)
{
  if (!consp (cell))
    error ("Not a cons cell", cell);
  NODE(cell)->u.cons.cdr = value;
  return cell;
}

/* -- Symbols ------------------------------------------------------------------------------ */

T make_symbol (const char *name)
{
  T res = alloc_node (TYPE_SYMBOL);
  T more = cons ((name[0] == ':') ? res : unbound,
                 cons (mk_string (GC_strdup (name)),
                       NIL));

  NODE(res)->u.symbol.function = unbound;
  NODE(res)->u.symbol.more = more;

  return res;
}

int symbolp (T object)
{
  return typep (object, TYPE_SYMBOL);
}

T symbol_value (T sym)
{
  T res;
  
  if (!symbolp (sym)) error ("Not a symbol", sym);

  if (null (sym))
    return NIL;

  res = car (NODE(sym)->u.symbol.more);
  if (eq (res, unbound))
    error ("Unbound symbol", sym);

  return res;
}

T symbol_function (T sym)
{
  T res;
  
  if (!symbolp (sym)) error ("Not a symbol", sym);

  if (null (sym)) goto bad;

  res = NODE(sym)->u.symbol.function;
  if (eq (res, unbound)) goto bad;

  return res;

 bad:
  error ("Undefined function", sym);
}

T symbol_plist (T sym)
{
  if (!symbolp (sym)) error ("Not a symbol", sym);

  if (null (sym))
    return NIL_plist;

  return cdr (cdr (NODE(sym)->u.symbol.more));
}

char *symbol_name (T sym)
{
  if (!symbolp (sym)) error ("Not a symbol", sym);

  if (null (sym))
    return "NIL";

  return NODE(car (cdr (NODE(sym)->u.symbol.more)))->u.string.string;
}

T set (T sym, T val)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    error ("You cannot set NIL", sym);
  else
    {
      rplaca (NODE(sym)->u.symbol.more, val);
      return val;
    }
}

T putd (T sym, T fun)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    error ("You cannot define NIL", sym);
  else
    {
      NODE(sym)->u.symbol.function = fun;
      return sym;
    }
}

T set_symbol_plist (T sym, T val)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    return NIL_plist = val;
  else
    return cdr (cdr (NODE(sym)->u.symbol.more));
}

T intern (const char *name)
{
  T q;

  if (0 == strcmp (name, "NIL")) return NIL;

  for (q = oblist; !null (q); q = cdr (q))
    {
      if (0 == strcmp (symbol_name (car (q)), name))
        return car (q);
    }

  /* fall through */
  q = make_symbol (name);
  oblist = cons (q, oblist);
  
  return q;
}

char *list_cstring (T name)
{
  int n;
  T q;
  char *cname;
  
  for (n = 0, q = name; consp (q); q = cdr (q), n++);
  cname = GC_malloc (n + 1);
  for (n = 0, q = name; consp (q); q = cdr (q), n++)
    cname[n] = get_num (car (q));
  cname[n] = '\0';
  return cname;
}

T subr_make_symbol (T name)
{
  return make_symbol (list_cstring (name));
}

T subr_intern (T name)
{
  return intern (list_cstring (name));
}

T subr_oblist (void)
{
  return cons (NIL, oblist);
}

int boundp (T sym)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    return 1;
  else
    return !eq (unbound, car (NODE(sym)->u.symbol.more));
}

int fboundp (T sym)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    return 0;
  else
    return !eq (unbound, NODE(sym)->u.symbol.function);
}

T makunbound (T sym)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    error ("You cannot make NIL unbound", sym);
  else
    {
      rplaca (NODE(sym)->u.symbol.more, unbound);
      return sym;
    }
}

T fmakunbound (T sym)
{
  if (!symbolp (sym))
    error ("Not a symbol", sym);
  else if (null (sym))
    error ("You cannot make NIL unbound", sym);
  else
    {
      NODE(sym)->u.symbol.function = unbound;
      return sym;
    }
}

T mk_string (char *string)
{
  T res = alloc_node (TYPE_STRING);

  NODE(res)->u.string.string = string;

  return res;
}

/* -- Numbers ------------------------------------------------------------------------------ */

#define MIN_FIXNUM -1000
#define MAX_FIXNUM 1000

T fixnums [MAX_FIXNUM - MIN_FIXNUM + 1];

T mk_num_aux (double x);

T mk_num (double x)
{
  if ((x >= MIN_FIXNUM) && (x <= MAX_FIXNUM) && ((int)(x) == x))
    return fixnums [(int)x - MIN_FIXNUM];
  else
    return mk_num_aux (x);
}

T mk_num_aux (double x)
{
  T res = alloc_node (TYPE_NUMBER);
  NODE(res)->u.number.val = x;
  return res;
}

int numberp (T object)
{
  return typep (object, TYPE_NUMBER);
}

double get_num (T object)
{
  if (!numberp (object))
    error ("Not a number", object);
  return NODE(object)->u.number.val;
}

int integerp (T object)
{
  double x = get_num (object);
  return isfinite (x) && (x == trunc (x));
}

T plus (T x, T y)               { return mk_num (get_num (x) + get_num (y)); }
T difference (T x, T y)         { return mk_num (get_num (x) - get_num (y)); }
T times (T x, T y)              { return mk_num (get_num (x) * get_num (y)); }
T quotient (T x, T y)           { return mk_num (get_num (x) / get_num (y)); }
/* ### These behave the same, check! */
T subr_rem (T x, T y)           { return mk_num (remainder (get_num (x), get_num (y))); }
T subr_mod (T x, T y)           { return mk_num (fmod (get_num (x), get_num (y))); }

T subr_truncate (T x)           { return mk_num (trunc (get_num (x))); }
T subr_sin (T x)                { return mk_num (sin (get_num (x))); }
T subr_cos (T x)                { return mk_num (cos (get_num (x))); }
T subr_tan (T x)                { return mk_num (tan (get_num (x))); }
T subr_expt (T x, T y)          { return mk_num (pow (get_num (x), get_num (y))); }
T subr_exp (T x)                { return mk_num (exp (get_num (x))); }
T subr_sqrt (T x)               { return mk_num (sqrt (get_num (x))); }
T subr_random (T x)             { return mk_num (get_num (x) * drand48 ()); }
/* ### no LOG? */

T subr_logior (T x, T y)        { return mk_num ((long)get_num(x) | (long)get_num(y)); }
T subr_logxor (T x, T y)        { return mk_num ((long)get_num(x) ^ (long)get_num(y)); }
T subr_logand (T x, T y)        { return mk_num ((long)get_num(x) & (long)get_num(y)); }
T subr_lognot (T x)             { return mk_num (~(long)get_num(x)); }
/* ### no ASH? */

int equ (T x, T y)              { return (get_num (x) == get_num (y)); }
int lessp (T x, T y)            { return (get_num (x) < get_num (y)); }

/* -- Predicates --------------------------------------------------------------------------- */

int eq (T x, T y)       { return x == y; }
int null (T x)          { return eq (NIL, x); }
int atom (T x)          { return !consp (x); }
int listp (T x)         { return consp (x) || null (x); }

int eql (T x, T y)
{
  if (numberp (x) && numberp (y))
    return get_num (x) == get_num (y);
  else
    return eq (x, y);
}

/* -- Console ------------------------------------------------------------------------------ */

#if USE_READLINE
int con_getc (void);
int con_ungetc (int c);
int con_putc (int c);

int con_rows = 0, con_cols = 0;

int my_getc (FILE *f)
{
  if (f == stdin)
    return con_getc ();
  else
    return getc (f);
}

int my_ungetc (int c, FILE *f)
{
  if (f == stdin)
    return con_ungetc (c);
  else
    return ungetc (c, f);
}

int my_putc (int c, FILE *f)
{
  if ((f == stdout) || (f == stderr))
    return con_putc (c);
  else
    return putc (c, f);
}

#ifdef getc
#undef getc
#endif

#ifdef ungetc
#undef ungetc
#endif

#ifdef putc
#undef putc
#endif

#define getc(f) my_getc(f)
#define ungetc(c,f) my_ungetc(c,f)
#define putc(c,f) my_putc(c,f)

char *con_rp = NULL;
int con_la = -1;

char con_curline [1000000];        /* ### */
int con_curcol = 0;

int con_putc (int c)
{
  if (c == '\n')
    {
      con_curline [con_curcol++] = c;
      con_curline [con_curcol] = 0;
      fputs (con_curline, stdout);
      con_curcol = 0;
    }
  else
    {
      con_curline [con_curcol++] = c;
      con_curline [con_curcol] = 0;
      // printf ("(%d)", con_curcol);
      if (con_curcol >= con_cols)
        {
          char *p = strrchr (con_curline, ' ');
          // printf ("#");
          if (p)
            {
              int k = p - con_curline;
              fwrite (con_curline, 1, k, stdout);
              fputc ('\n', stdout);
              con_curcol -= (k + 1);
              memcpy (con_curline, con_curline + (k+1), con_curcol + 1);
            }
          else
            {
              /* Nothing we could do */
            }
        }
    }
  return 0;
}

int con_getc (void)
{
  int c;
  
  if (con_la != -1)
    {
      int c = con_la;
      con_la = -1;
      return c;
    }

  if (con_rp == NULL)
    {
      con_rp = readline (con_curline);
      con_curcol = 0;
      con_curline[0] = 0;
      if (con_rp == NULL)
        return EOF;
      add_history (con_rp);
    }

  c = *(con_rp++);
  if (c == '\0')
    {
      con_rp = NULL;
      return '\n';
    }
  else
    return c;
}

int con_ungetc (int c)
{
  con_la = c;
  return c;
}

#endif

/* -- I/O ---------------------------------------------------------------------------------- */

struct file_entry {
  T file_sym;
  FILE *file;
};

struct file_entry *file_table;
int file_table_size = 0;

T alloc_file (FILE *file, T sym)
{
  int i;
  for (i = 0; i < file_table_size; i++)
    if (file_table[i].file == NULL)
      goto found;

  /* fall through, the table is full */
  if (file_table_size == 0)
    {
      file_table_size = 32;
      file_table = GC_malloc (sizeof (struct file_entry) * file_table_size);
    }
  else
    {
      file_table_size = file_table_size + file_table_size/2;
      file_table = GC_realloc (file_table, sizeof (struct file_entry) * file_table_size);
    }

 found:
  file_table[i].file = file;
  file_table[i].file_sym = sym;
  return cons (kSTREAM,
               cons (mk_num (i),
                     cons (sym, NIL)));
}

int filep (T x);
FILE *file_file (T x);
T make_file (FILE *f);

void tyo (int c, T stream)
{
  if (filep (stream))
    putc (c, file_file (stream));
  else if (consp (stream))
    {
      T tail = cdr (stream);
      T q = cons (mk_num (c), NIL);

      if (null (tail))
        rplacd (rplaca (stream, q), q);
      else
        rplacd (stream, cdr (rplacd (tail, q)));
    }
  else
    error ("Not a stream", stream);
}

void tyos (const char *s, T stream)
{
#if 0
  if (filep (stream))
    {
      FILE *f = file_file (stream);
      // fputs (s, file_file (stream));
      while (*s) putc (*s, f), s++;
    }
  else
#endif
    while (*s) tyo (*(s++), stream);
}

int tyi (T stream)
{
  if (filep (stream))
    return getc (file_file (stream));
  else if (consp (stream))
    {
      if (null (car (stream)))
        return EOF;
      else
        {
          int res = get_num (caar (stream));
          rplaca (stream, cdar (stream));
          if (null (car (stream)))
            rplacd (stream, NIL);
          return res;
        }
    }
  else
    error ("Not a stream", stream);
}

void untyi (int c, T stream)
{
  if (filep (stream))
    ungetc (c, file_file (stream));
  else if (consp (stream))
    {
      rplaca (stream, cons (mk_num (c), caar (stream)));
      if (null (cdr (stream)))
        rplacd (stream, car (stream));
    }
  else
    error ("Not a stream", stream);
}

int filep (T file)
{
  return (consp (file) &&
          eq (kSTREAM, car (file)));
}

struct file_entry *file_file_entry (T file)
{
  int n;
  struct file_entry *f;

  if (null (cadr (file)))
    goto closed_flame;

  n = get_num (cadr (file));

  if (n < 0) goto bad;
  if (n >= file_table_size) goto bad;
  
  f = file_table + n;

  /* ### Hmm, the error message might be misleading, since we reuse
         handles */
  
  if (!eq (f->file_sym, caddr (file)))
    goto bad;
  
  if (f->file == NULL)
    goto closed_flame;

  return f;

 closed_flame:
  error ("Attemp to use a closed stream", file);
 bad:
  error ("Bad stream", file);
}

FILE *file_file (T file)
{
  return file_file_entry (file)->file;
}

T subr_openi (T filename)
{
  FILE *f = fopen (symbol_name (filename), "r");
  return f ? alloc_file (f, make_symbol (symbol_name (filename))) : NIL;
}

T subr_openo (T filename)
{
  FILE *f = fopen (symbol_name (filename), "w");
  return f ? alloc_file (f, make_symbol (symbol_name (filename))) : NIL;
}

T subr_close (T stream)
{
  struct file_entry *f;
  if (!filep (stream))
    error ("Not a stream", stream);
  f = file_file_entry (stream);
  fclose (f->file);
  f->file = NULL;
  rplaca (cdr (stream), NIL);
  return NIL;
}

/* -- Reader ------------------------------------------------------------------------------- */

T decode_input_stream_designator (T stream);

#define WSPACE "\t \f\r\n"

#define CONSTITUENT                             \
  "abcdefghijklmnopqrstuvwxyz"                  \
  "!$%&*+-./0123456789:<=>?@[]^_{}~"            \
  "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

struct buf {
  int room, p;;
  char *s;
};

#define BUF_INIT { 0, 0, "" }

void buf_put (struct buf *buf, int c)
{
  if (buf->p >= buf->room)
    {
      buf->room = buf->room + buf->room/2;
      if (buf->room == 0)
        {
          buf->room = 32;
          buf->s = GC_malloc (buf->room + 1);
        }
      else
        buf->s = GC_realloc (buf->s, buf->room + 1);
    }
  buf->s[buf->p++] = c;
}

int constituent_char_p (int c);

T read_object (T input, int in_list_p)
{
  int c;

 again:
  c = tyi (input);
  if (c == EOF)
    {
      if (!(in_list_p & 2))
        error ("EOF", input);
      return sFIN;
    }

  if (strchr (WSPACE, c))
    goto again;
  else if (constituent_char_p (c))
    {
      struct buf buf = BUF_INIT;

      do {
        buf_put (&buf, toupper (c));
        c = tyi (input);
      }while ((c != EOF) && strchr (CONSTITUENT, c));

      if (c != EOF)
        untyi (c, input);
      buf_put (&buf, '\0');

      {
        double d;
        char *endptr;

        if (0 == strcmp (buf.s, "."))
          {
            if (!(in_list_p & 1))
              error ("Stray dot", input);
            else
              return dot;
          }
        else
          {
            d = strtod (buf.s, &endptr);
            if (*endptr)
              return intern (buf.s);
            else
              return mk_num (d);
          }
      }
    }
  else if (c == '(')
    {
      T res = NIL, tail = NIL, x;

      for (;;)
        {
          x = read_object (input, 1);
          if (eq (x, rparen))
            return res;
          if (eq (x, dot))
            {
              if (null (tail))
                error ("Premature dot.", NIL);
              x = read_object (input, 1);
              rplacd (tail, x);
              x = read_object (input, 1);
              if (!eq (x, rparen))
                error ("')' expected.", NIL);
              return res;
            }
          else
            {
              if (null (tail))
                res = tail = cons (x, NIL);
              else
                {
                  rplacd (tail, x = cons (x, NIL));
                  tail = x;
                }
            }
        }
    }
  else if (c == ')')
    {
      if (!(in_list_p & 1))
        error ("Unmatched ')'", input);
      return rparen;
    }
  else if (c == ';')
    {
      while ((c = tyi (input), c != EOF && c != '\n'));
      goto again;
    }
  else if (c == '\'')
    {
      return cons (sQUOTE, cons (read_object (input, 0), NIL));
    }
  else if (c == '`')
    {
      return cons (sBACKQUOTE, cons (read_object (input, 0), NIL));
    }
  else if (c == ',')
    {
      c = tyi (input);
      if (c == '@')
        return cons (sCOMMA_AT, cons (read_object (input, 0), NIL));
      else
        {
          if (c != EOF)
            untyi (c, input);
          return cons (sCOMMA, cons (read_object (input, 0), NIL));
        }
    }
  else if (c == '#')
    {
      c = tyi (input);
      switch (c)
        {
        case '\'':
          return cons (sFUNCTION, cons (read_object (input, 0), NIL));

        case '\\':
          /* ### */
          return mk_num (tyi (input));

        default:
          error ("Bad character after #", mk_num (c));
        }
    }
  else if (c == '"')
    {
      struct buf buf = BUF_INIT;

      /* Can we fake a string reader? */

      for (;;)
        {
          c = tyi (input);

          if (c == EOF)
            error ("Unterminated string", NIL);
          
          if (c == '\\')
            {
              c = tyi (input);
              if (c == EOF)
                error ("Unterminated string", NIL);
            }

          if (c == '"')
            break;

          buf_put (&buf, c);
        }

      {
        T r = make_symbol (buf.s);
        set (r, r);
        return r;
      }
    }
  else
    error ("Bad char", mk_num (c));
}

int constituent_char_p (int c)
{
  return !!strchr (CONSTITUENT, c);
}

T subr_read (T stream, T eof)
{
  T r = read_object (decode_input_stream_designator (stream),
                     null (eof) ? 0 : 2);

  return (eq (r, sFIN)) ? eof : r;
}

T decode_input_stream_designator (T stream)
{
  /* ### what does CL do? */
  if (eq (NIL, stream)) return symbol_value (intern ("*STANDARD-INPUT*"));
  if (eq (sT, stream)) return symbol_value (intern ("*STANDARD-INPUT*"));
  return stream;
}

/* -- Printer ------------------------------------------------------------------------------ */

T decode_output_stream_designator (T stream);
int needs_escape_p (const char *pname);

void write_object (T object, T stream, int escapep)
{
  if (symbolp (object))
    {
      if (escapep && needs_escape_p (symbol_name (object)))
        {
          char *s;
          tyo ('"', stream);
          for (s = symbol_name (object); *s; s++)
            {
              int c = *s;
              if ((c == '"') || (c == '\\'))
                tyo ('\\', stream);
              tyo (c, stream);
            }
          tyo ('"', stream);
        }
      else
        tyos (symbol_name (object), stream); /* ### */
    }
  else if (numberp (object))
    {
      /* 6 digits may not be enough! */
      char buf[6 /* digits */ + 1 /* dot */ + 1 /* sign */ + 5 /* exp */ + 1 /* '\0' */];
      sprintf (buf, "%g", get_num (object));
      tyos (buf, stream);
    }
  else if (consp (object) &&
           eq (car (object), sQUOTE) &&
           consp (cdr (object)) &&
           null (cddr (object)))
    {
      tyo ('\'', stream);
      write_object (cadr (object), stream, escapep);
    }
  else if (consp (object))
    {
      int i;
      tyo ('(', stream);

      for (i = 0; consp (object); object = cdr (object), i++)
        {
          if (i) tyo (' ', stream);
          write_object (car (object), stream, escapep);
        }

      if (!null (object))
        {
          tyos (" . ", stream);
          write_object (object, stream, escapep);
        }
        
      tyo (')', stream);
    }
  else
    tyos ("#<Unknown object>", stream); /* should not happen */
}

int needs_escape_p (const char *pname)
{
  const char *s;
  char *endptr;

  /* Every char must be constituent and has to be upper case */

  for (s = pname; *s; s++)
    if (!constituent_char_p (*s) || (toupper (*s) != *s))
      return 1;

  /* It could still happen that the string might match the syntax of a
     number */
  
  strtod (pname, &endptr);
  return *endptr == '\0';
}

T force_output (T stream)
{
  stream = decode_output_stream_designator (stream);
  if (filep (stream))
    fflush (file_file (stream));
  return sT;
}

T prin1 (T object, /* &optional */ T stream)
{
  if (eq (unbound, stream))
    stream = sT;

  stream = decode_output_stream_designator (stream);
  write_object (object, stream, 1);
  force_output (stream);

  return object;
}

T princ (T object, /* &optional */ T stream)
{
  if (eq (unbound, stream))
    stream = sT;

  write_object (object, decode_output_stream_designator (stream), 0);
  force_output (stream);

  return object;
}

T terpri (/* &optional */ T stream)
{
  if (eq (unbound, stream))
    stream = sT;

  stream = decode_output_stream_designator (stream);
  tyo ('\n', stream);
  return NIL;
}

T print (T object, /* &optional */ T stream)
{
  terpri (stream);
  prin1 (object, stream);
  force_output (stream);
  return object;
}

T decode_output_stream_designator (T stream)
{
  /* ### what does CL do? */
  if (eq (NIL, stream)) return symbol_value (intern ("*STANDARD-OUTPUT*"));
  if (eq (sT, stream)) return symbol_value (intern ("*STANDARD-OUTPUT*"));
  return stream;
}

/* -- Eval --------------------------------------------------------------------------------- */

T evsym (T sym, T env);
T apply_closure (T params_body, T cenv, T args, T env, int evalp);
/* todo */
T evfun (T form, T env);
int fsubrp (T x);
T apply_subr (T subr, T args, T env, int evlap);
int closurep (T x);
T closure_param_body (T closure);
T closure_env (T closure);
T make_closure (T param_body, T cenv);
int macrop (T x);
int subrp (T x);
T evlis (T forms, T env);
T apply_fun (T form, T fun, T args, T env, int evalp);
T make_closure (T param_body, T cenv);
T (*fsubr_fun (T x)) (T form, T env);

T eval (T form, T env)
{
  T fun;

  if (symbolp (form))
    return evsym (form, env);

  if (atom (form))
    return form;

  fun = car (form);

  if (symbolp (fun))
    return apply_fun (form, fun, cdr (form), env, 1);

  if (consp (fun) && eq (sLAMBDA, car (fun)))
    return apply_closure (cdr (fun), env,
                          cdr (form), env, 1);

  error ("Bad function in form", form);
}

T evsym (T sym, T env)
{
  T q;

  for (q = env; consp (q); q = cdr (q))
    if (eq (sym, caar (q)))
      return cdar (q);

  /* fall through */
  return symbol_value (sym);
}

T evfun (T form, T env)
{
  if (symbolp (form))
    return symbol_function (form);

  if (atom (form))
    goto bad;

  if (eq (sLAMBDA, car (form)))
    return make_closure (cdr (form), env);

 bad:
  error ("Bad function", form);
}

T apply_fun (T form, T fun, T args, T env, int evalp)
{
  /* 
   * ### misnommer
   * 
   * ### form?
   */

  T ofun = fun;
      
  if (symbolp (fun))
    fun = evfun (fun, env);

  if (fsubrp (fun))
    {
      if (!evalp)
        error ("You cannot call an FSUBR", ofun);
      else
        return fsubr_fun (fun) (form, env);
    }

  if (subrp (fun))
    return apply_subr (fun, args, env, evalp);

  if (closurep (fun))
    return apply_closure (closure_param_body (fun),
                          closure_env (fun),
                          args, env,
                          evalp);

  if (macrop (fun))
    {
      if (!evalp)
        error ("You cannot call a macro", ofun);
      else
        return eval (apply_fun (NIL, cdr (fun), cons (form, cons (env, NIL)), NIL, 0), env);
    }

  error ("Bad function", fun);
}

T apply_closure (T params_body, T cenv, T args, T env, int evalp)
{
  T p, a;

  for (p = car (params_body), a = args;
       consp (p) && consp (a);
       p = cdr (p), a = cdr (a))
    {
      T sym = car (p);
      T arg = car (a);

  if (eq (sym, aOPTIONAL))
    break;

  if (0){
      prin1 (cons (intern ("***"),
                   cons (sym,
                         cons (aOPTIONAL,
                               NIL))),
             sT);
      terpri (sT);
  }
  
      if (!symbolp (sym))
        error ("Parameter is not a symbol", sym);

      cenv = cons (cons (sym, evalp ? eval (arg, env) : arg), cenv);
    }

  if (!listp (p))            /* dotted parameter list => our &REST */
    {
      if (!symbolp (p))
        error ("Parameter is not a symbol", p);
      cenv = cons (cons (p, evalp ? evlis (a, env) : a), cenv);
      a = NIL;
      p = NIL;
    }

  if (eq (car (p), aOPTIONAL))
    {
      goto optional;
    }
        
 done:
  if (consp (p))
    error ("Too few arguments", cons (car (params_body), cons (args, NIL)));

  if (consp (a))
    error ("Too many arguments", cons (car (params_body), cons (args, NIL)));

  return fsubr_progn (params_body, cenv);

 optional:
  p = cdr (p);
  for (; consp (p);
       p = cdr (p), a = cdr (a))
    {
      T par = car (p);
      T arg = car (a);
      T sym = consp (par) ? car (par) : par;

      if (!symbolp (sym))
        error ("Parameter is not a symbol", sym);

      cenv = cons (cons (sym,
                         (consp (a)
                          ? (evalp ? eval (arg, env) : arg)
                          : (consp (par)
                             ? eval (cadr (par), cenv)
                             : NIL))),
                   cenv);
    }
  goto done;
}

T evlis (T forms, T env)
{
  /* ### */
  T x, y;
  if (atom (forms)) return NIL;
  x = eval (car (forms), env);
  y = evlis (cdr (forms), env);
  return cons (x, y);
}

T subr_apply (T fun, T args)
{
  return apply_fun (NIL, fun, args, NIL, 0);
}

/* -- FSUBRs ------------------------------------------------------------------------------- */

int fsubrp (T object)
{
  return consp (object) && eq (sFSUBR, car (object));
}

T (*fsubr_fun (T x)) (T form, T env)
{
  int k = get_num (cdr (x));

  if ((k >= 0) && (k < sizeof (fsubr_table) / sizeof (fsubr_table[0]) - 1))
    return fsubr_table[k];
  else
    error ("Bad FSUBR", x);
}

T fsubr_quote (T form, T env)
{
  T q;

  q = cdr (form);
  if (!consp (q)) error ("Too few arguments", form);
  if (!null (cdr (q))) error ("Too many arguments", form);
  return car (q);
}

T fsubr_setq (T form, T env)
{
  T p, q, sym, val = NIL;

  q = cdr (form);

  while (consp (q))
    {
      sym = car (q);
      if (!symbolp (sym))
        error ("Not a symbol", sym);
      q = cdr (q);

      if (!consp (q))
        error ("Odd number of arguments to SETQ", form);
      val = eval (car (q), env);
      q = cdr (q);

      for (p = env; consp (p); p = cdr (p))
        if (eq (caar (p), sym))
          {
            rplacd (car (p), val);
            goto done;
          }
      /* fall through */
      set (sym, val);

    done:
      ;
    }

  return val;
}

T fsubr_if (T form, T env)
{
  /* ### */
  T test, conseq, alt;

  form = cdr (form);
  test = car (form); form = cdr (form);
  conseq = car (form); form = cdr (form);
  alt = car (form); form = cdr (form);

  if (!null (eval (test, env)))
    return eval (conseq, env);
  else
    return eval (alt, env);
}

T fsubr_progn (T form, T env)
{
  /* ### TCO */
  T q, res = NIL;

  for (q = cdr (form); consp (q); q = cdr (q))
    res = eval (car (q), env);

  return res;
}

T fsubr_function (T form, T env)
{
  /* ### arg check */
  /* ### should return only functions */
  return evfun (cadr (form), env);
}

/* -- TAGBODY ------------------------------------------------------------------------------ */

struct cframe {
  jmp_buf buf;
  T binding;
  T ret;
  struct cframe *link;
};

struct cframe *cstack = 0;

T fsubr_tagbody (T form, T env)
{
  T tags = NIL;
  T q;
  struct cframe frame;

  for (q = cdr (form); consp (q); q = cdr (q))
    if (atom (car (q)))
      tags = cons (q, tags);

  env = cons (q = cons (tag_marker, tags), env);

  frame.link = cstack;
  frame.binding = q;
  frame.ret = cdr (form);

  q = setjmp (frame.buf) ? frame.ret : cdr (form);
  cstack = &frame;

  for (q = frame.ret; consp (q); q = cdr (q))
    if (!atom (car (q)))
      eval (car (q), env);

  cstack = frame.link;
  
  return NIL;
}

T fsubr_go (T form, T env)
{
  T p, q, tag, binding;
  struct cframe *f;

  tag = cadr (form);            /* ### */

  /* Find tag */
  for (q = env; consp (q); q = cdr (q))
    {
      binding = car (q);
      if (eq (tag_marker, car (binding)))
        for (p = cdr (binding); consp (p); p = cdr (p))
          if (eq (tag, caar (p)))
            goto found;
    }
  /* fall through */
  error ("GO tag undefined", tag);

 found:

  for (f = cstack; f; f = f->link)
    if (eq (f->binding, binding))
      goto found_frame;

  /* fall through */
  error ("GO tag stale", tag);

 found_frame:

  f->ret = cdar (p);
  
  longjmp (f->buf, 1);
}

T fsubr_block (T form, T env)
{
  T name = cadr (form);
  struct cframe frame;

  frame.binding = cons (block_marker, name);
  env = cons (frame.binding, env);

  frame.link = cstack;
  frame.ret = NIL;
  cstack = &frame;

  if (0 == setjmp (frame.buf))
    frame.ret = fsubr_progn (cdr (form), env);

  cstack = frame.link;
  
  return frame.ret;
}

T fsubr_return_from (T form, T env)
{
  T name = cadr (form);
  T value = eval (caddr (form), env);
  T q, binding;
  struct cframe *f;

  /* Find block */
  for (q = env; consp (q); q = cdr (q))
    {
      binding = car (q);
      if (eq (block_marker, car (binding)) &&
          eq (name, cdr (binding)))
        goto found;
    }
  /* fall through */
  error ("BLOCK undefined", name);

 found:

  for (f = cstack; f; f = f->link)
    if (eq (f->binding, binding))
      goto found_frame;

  /* fall through */
  error ("Stale BLOCK", name);

 found_frame:

  f->ret = value;
  
  longjmp (f->buf, 1);
}

/* -- SUBRs -------------------------------------------------------------------------------- */

int subrp (T object)
{
  return consp (object) && eq (sSUBR, car (object));
}

int subr_ptr (T subr)
{
  return get_num (cadr (subr));
}

/* -- Closures ----------------------------------------------------------------------------- */

/*
 * We have no closure datatype, but instead use:
 *
 *     (CLOSURE <env> <parameters> . <body>)
 *
 * and macros look like
 *
 *     (MACRO . <closure>)
 */

T make_closure (T param_body, T cenv)
{
  return cons (sCLOSURE, cons (cenv, param_body));
}

int closurep (T x)
{
  return consp (x) && eq (sCLOSURE, car (x));
}

int macrop (T x)
{
  return consp (x) && eq (sMACRO, car (x));
}

T closure_param_body (T closure)
{
  return cddr (closure);
}

T closure_env (T closure)
{
  return cadr (closure);
}

/* ----------------------------------------------------------------------------------------- */

char *fmt_decimal (uintmax_t u, char *buf, size_t n);

T subr_room (void)
{
  char buf [100];
  T s = decode_output_stream_designator (sT);
  
  /* ### second buffer for fmt_decimal */

  sprintf (buf, "Total:       %12s bytes\n", fmt_decimal (GC_get_heap_size(), buf, sizeof (buf)));
  tyos (buf, s);
  sprintf (buf, "Free:        %12s bytes\n", fmt_decimal (GC_get_free_bytes(), buf, sizeof (buf)));
  tyos (buf, s);
  sprintf (buf, "Used:        %12s bytes\n", fmt_decimal (GC_get_heap_size() - GC_get_free_bytes(), buf, sizeof (buf)));
  tyos (buf, s);
  // sprintf (buf, "Collections: %ld\n", (long)GC_gc_no);
  tyos (buf, s);

  return NIL;
}

T subr_quit (T exitcode)
{
  exit (null (exitcode) ? 0 : get_num (exitcode));
}

T subr_gc (void)
{
  GC_gcollect ();
  return NIL;
}

char *fmt_decimal (uintmax_t u, char *buf, size_t n)
{
  char *p;
  int i;

  if (u == 0) return "0";

  p = buf + n;
  *(--p) = 0;
  i = 0;
  
  while (u)
    {
      if (p == buf) abort ();
      if (i && i % 3 == 0) *(--p) = ',';
      if (p == buf) abort ();
      *(--p) = (u % 10) + '0';
      u /= 10;
      i++;
    }

  return p;
}

/* -- I/O ---------------------------------------------------------------------------------- */

T subr_read_char (T stream)
{
  stream = decode_input_stream_designator (stream);
  return mk_num (tyi (stream));
}

T subr_peek_char (T type, T stream)
{
  int c;
  stream = decode_input_stream_designator (stream);
 again:
  c = tyi (stream);
  if (!null(type) && strchr (WSPACE, c))
    goto again;
  if (c != EOF)
    untyi (c, stream);
  return mk_num (c);
}

T subr_write_char (T c, T stream)
{
  stream = decode_output_stream_designator (stream);
  tyo (get_num (c), stream);
  return c;
}

/* -- Tables ------------------------------------------------------------------------------- */

struct subr_entry {
  unsigned sig;
  void *fun;
  char *name;
};

const struct subr_entry subr_table [] = {
  { 2, cons, "CONS" },
  { 1, car, "CAR" },
  { 1, cdr, "CDR" },
  { 2, rplaca, "RPLACA" },
  { 2, rplacd, "RPLACD" },
  { 1, symbol_value, "SYMBOL-VALUE" },
  { 1, symbol_function, "SYMBOL-FUNCTION" }, /* x */
  { 1, symbol_plist, "SYMBOL-PLIST" },
  { 2, set, "SET" },
  { 2, putd, "PUTD" },          /* x */
  { 2, set_symbol_plist, "SET-SYMBOL-PLIST" },
  { 0, subr_oblist, "OBLIST" },
  { 1, subr_make_symbol, "MAKE-SYMBOL" },
  { 1, subr_intern, "INTERN" },
  { 1, makunbound, "MAKUNBOUND" }, /* x */
  { 1, fmakunbound, "FMAKUNBOUND" }, /* x */
  { 2, plus, "PLUS" },
  { 2, difference, "DIFFERENCE" },
  { 2, times, "TIMES" },
  { 2, quotient, "QUOTIENT" },
  { 2, subr_rem, "REM" },
  { 2, subr_mod, "MOD" },
  { 2, prin1, "PRIN1" },
  { 2, princ, "PRINC" },
  { 2, print, "PRINT" },
  { 1, terpri, "TERPRI" },
  { 2, subr_read, "READ" },
  { 2, eval, "EVAL" },
  { 2, subr_apply, "APPLY" },
  { 0x11, consp, "CONSP" },
  { 0x11, symbolp, "SYMBOLP" },
  { 0x11, boundp, "BOUNDP" },
  { 0x11, fboundp, "FBOUNDP" }, /* x */
  { 0x11, numberp, "NUMBERP" },
  { 0x11, integerp, "INTEGERP" }, /* ??? */
  { 0x12, equ, "EQU" },           /* x */
  { 0x12, lessp, "LESSP" },
  { 0x12, eq, "EQ" },
  { 0x11, null, "NULL" },
  { 0x11, null, "NOT" },
  { 0x11, atom, "ATOM" },
  { 0x11, listp, "LISTP" },
  { 0x12, eql, "EQL" },
  { 1, &subr_truncate, "TRUNCATE" },
  { 1, &subr_sin, "SIN" },
  { 1, &subr_cos, "COS" },
  { 1, &subr_tan, "TAN" },
  { 2, &subr_expt, "EXPT" },
  { 1, &subr_exp, "EXP" },
  { 1, &subr_sqrt, "SQRT" },
  { 1, &subr_random, "RANDOM" },
  { 2, &subr_logior, "LOGIOR" },
  { 2, &subr_logxor, "LOGXOR" },
  { 2, &subr_logand, "LOGAND" },
  { 1, &subr_lognot, "LOGNOT" },
  { 0, &subr_room, "ROOM" },
  { 0, &subr_gc, "GC" },
  { 1, &subr_quit, "QUIT" },
  { 1, &subr_read_char, "READ-CHAR" },
  { 2, &subr_peek_char, "PEEK-CHAR" },
  { 2, &subr_write_char, "WRITE-CHAR" },
  { 1, &subr_openi, "OPENI" },
  { 1, &subr_openo, "OPENO" },
  { 1, &subr_close, "CLOSE" },
  
  { 0, 0, 0 }
};

#define NSUBR (sizeof (subr_table) / sizeof(subr_table[0]) - 1)

const struct subr_entry *subr_entry (int k)
{
  if ((k >= 0) && (k < NSUBR))
    return subr_table + k;
  else
    error ("Bad subr", mk_num (k));
}

T apply_subr (T subr, T args, T env, int evalp)
{
  const struct subr_entry *info = subr_entry (subr_ptr (subr));
  int n = info->sig & 0xF;
  void *fun = info->fun;
  T a [n];
  int i;

  /* All arguments are optional */
  
  for (i = 0; i < n; i++, args = cdr (args))
    a[i] = evalp ? eval (car (args), env) : car (args);

  if (!null (args))
    error ("Too many arguments", subr); /* ### better */

  switch (info->sig)
    {
    case 0:
      return ((T (*) (void)) fun)();
    case 1:
      return ((T (*) (T)) fun)(a[0]);
    case 2:
      return ((T (*) (T, T)) fun)(a[0], a[1]);
    case 0x11:
      return ((int (*) (T)) fun)(a[0]) ? sT : NIL;
    case 0x12:
      return ((int (*) (T, T)) fun)(a[0], a[1]) ? sT : NIL;
    default:
      abort ();
    }
}

/* -- Init --------------------------------------------------------------------------------- */

void init (void)
{
  T x;
  int k;
  
  /* GC */
  GC_enable_incremental ();     /* This reduces the memory foot print, for some reason. */
  // GC_set_free_space_divisor (2);
  // GC_set_full_freq(1);
  GC_INIT ();

  for (k = MIN_FIXNUM; k <= MAX_FIXNUM; k++)
    fixnums[k - MIN_FIXNUM] = mk_num_aux (k);

  /* markers */
  unbound = make_symbol ("#<unbond>");
  dot = make_symbol ("#<dot>");
  rparen = make_symbol ("#<rparen>");
  tag_marker = make_symbol ("#<tag>");
  block_marker = make_symbol ("#<block>");
  sFIN = make_symbol ("#<eof>");

#define _(var,name) var = intern (name);
  SYMBOLS;
#undef _

  set (sT, sT);

#define _(fun,name) x = intern(name); putd (x, cons (sFSUBR, mk_num (k++)));
  k = 0;
  FSUBRS;
#undef _

  {
    int i;
    for (i = 0; i < NSUBR; i++)
      {
        x = intern (subr_table[i].name);
        putd (x, cons (sSUBR, cons (mk_num (i), cons (x, NIL))));
      }
  }

  set (intern ("*STANDARD-INPUT*"), alloc_file (stdin, make_symbol ("/dev/stdin")));
  set (intern ("*STANDARD-OUTPUT*"), alloc_file (stdout, make_symbol ("/dev/stdout")));
  set (intern ("*ERROR-OUTPUT*"), x = alloc_file (stderr, make_symbol ("/dev/stderr")));
}

/* -- Main --------------------------------------------------------------------------------- */

void herald (void)
{
  printf (";;\n");
  printf (";; Lucky Lisp\n");
  printf (";;\n");
}

void error (const char *msg, T x)
{
  T s = symbol_value (intern ("*ERROR-OUTPUT*"));
  princ (make_symbol ("*** ERROR: "), s);
  princ (make_symbol (msg), s);
  princ (make_symbol (" - "), s);
  prin1 (x, s);
  terpri (s);
  abort ();
}

T driver_eval (T form)
{
  return eval (cons (intern ("EVAL"),
                     cons (cons (sQUOTE,
                                 cons (form, NIL)),
                           NIL)),
               NIL);
}

int main (int argc, char **argv)
{
  T x;
  
  (void)argc;
  (void)argv;

#if USE_READLINE
  using_history ();
  {
    rl_initialize ();
    rl_get_screen_size (&con_rows, &con_cols);
    // printf ("%d x %d; %d\n", con_cols, con_rows, isatty (0));
  }
#endif

  init ();
  herald ();

  if (1) {
    int i;
    for (i = 1; i < argc; i++)
      {
        FILE *f = fopen (argv [i], "r");
        T input;
        if (f == NULL)
          error ("Cannot open file", make_symbol (argv [i]));
        input = alloc_file (f, make_symbol (argv[1]));

        while (!eq (sFIN, x = read_object (input, 2))) /* ### */
          {
            prin1 (driver_eval (x), sT);
            terpri (sT);
          }
        rplaca (cdr (input), NIL);
        fclose (f);
      }
  }

  for (;;)
    {
      T x;
      tyos ("Input: ", decode_output_stream_designator (sT));
      x = subr_read (sT, sFIN);
      if (eq (x, sFIN))
        {
          terpri (sT);
          break;
        }
      x = driver_eval (x);
      prin1 (x, sT);
      terpri (sT);
    }
  
  return 0;
}