/*
 * This file is part of the Poliqarp suite.
 * 
 * Copyright (C) 2004-2009 by Instytut Podstaw Informatyki Polskiej
 * Akademii Nauk (IPI PAN; Institute of Computer Science, Polish
 * Academy of Sciences; cf. www.ipipan.waw.pl).  All rights reserved.
 * 
 * This file may be distributed and/or modified under the terms of the
 * GNU General Public License version 2 as published by the Free Software
 * Foundation and appearing in the file gpl.txt included in the packaging
 * of this file.  (See http://www.gnu.org/licenses/translations.html for
 * unofficial translations.)
 * 
 * A commercial license is available from IPI PAN (contact
 * Michal.Ciesiolka@ipipan.waw.pl or ipi@ipipan.waw.pl for more
 * information).  Licensees holding a valid commercial license from IPI
 * PAN may use this file in accordance with that license.
 * 
 * This file is provided AS IS with NO WARRANTY OF ANY KIND, INCLUDING
 * THE WARRANTY OF DESIGN, MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 * PURPOSE.
 */

#include <foostring/foostring.h>

#include "lisp.h"

lptr make_builtin_symbol(lisp_env * env, const char *name, lptr value)
{
   return intern_symbol(env, make_symbol(env, make_static_string(env, name),
         value), Qnil);
}

DEF_SPECIAL(t, L_LISP_T)
DEF_SPECIAL(void, L_LISP_VOID)
DEF_SPECIAL(undefined, L_LISP_UNDEFINED)
DEF_SPECIAL(error, L_LISP_ERROR)

struct lisp_env *make_lisp_env(void)
{
   struct marena misc_arena;
   struct lisp_env *env;

   marena_create(&misc_arena);
   env = marena_alloc(&misc_arena, sizeof *env);
   env->flist8 = Qnil;
   env->flist16 = Qnil;
   env->misc_arena = misc_arena;
   marena_create(&env->cell_arena);


   env->obarray = make_obarray(env, L_OBARRAY_SIZE);
   make_builtin_symbol(env, "t", Qt);
   env->globals.common_glue = make_builtin_symbol(env, "*common-glue*", Qnil);
   env->globals.auto_newline = make_builtin_symbol(env, "*auto-newline*", Qt);
   env->user_data = NULL;
   return env;
}

void free_lisp_env(lisp_env * env)
{
   struct marena misc_arena = env->misc_arena;

   marena_destroy(&env->cell_arena);
   marena_destroy(&misc_arena);
}

void lisp_set_user_data(lisp_env * env, void *data)
{
   env->user_data = data;
}

void *lisp_get_user_data(lisp_env * env)
{
   return env->user_data;
}

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

lptr alloc_cell8(lisp_env * env)
{
   lptr this;
   if (env->flist8 != Qnil) {
      /* reuse existing cell */
      this = env->flist8;
      env->flist8 = L_CAR(this);
   } else
      /* allocate new cell */
      this = (lptr) marena_alloc(&env->cell_arena, (sizeof(lisp_cell8)));
   L_CAR(this) = Qnil;
   L_CDR(this) = Qnil;
   return this;
}

lptr alloc_cell16(lisp_env * env)
{
   lptr this;
   if (env->flist16 != Qnil) {
      /* reuse existing cell */
      this = env->flist16;
      env->flist16 = L_CAR(this);
   } else
      /* allocate new cell */
      this = (lptr) marena_alloc(&env->cell_arena, (sizeof(lisp_cell16)));
   L_CAR(this) = Qnil;
   L_CDR(this) = Qnil;
   return this;
}

void free_cell16(lisp_env * env, lptr this)
{
   L_CAR(this) = env->flist16;
   env->flist16 = this;
}

void free_cell8(lisp_env * env, lptr this)
{
   L_CAR(this) = env->flist8;
   env->flist8 = this;
}

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

lptr make_cons(lisp_env * env, lptr car, lptr cdr)
{
   lptr this = alloc_cell8(env);
   assert(L_TYPEP(this, CONS));
   L_CAR(this) = car;
   L_CDR(this) = cdr;
   return this;
}

lptr make_vector(lisp_env * env, size_t size)
{
   lptr this;
   size_t i;

   assert(sizeof(vector_cell) == sizeof(lisp_cell8));

   this = alloc_cell8(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_VECTOR, size);
   L_VECTOR_CELLS(this) = malloc(sizeof *L_VECTOR_CELLS(this) * size);
   for (i = 0; i < size; ++i)
      L_VECTOR_CELL(this, i) = Qundefined;
   return this;
}

lptr make_obarray(lisp_env * env, size_t size)
{
   lptr this;
   size_t i;

   assert(sizeof(vector_cell) == sizeof(lisp_cell8));

   this = alloc_cell8(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_OBARRAY, size);
   L_VECTOR_CELLS(this) = malloc(sizeof *L_VECTOR_CELLS(this) * size);
   for (i = 0; i < size; ++i)
      L_VECTOR_CELL(this, i) = Qnil;
   return this;
}

lptr make_string(lisp_env * env, const char *text)
{
   lptr this;

   assert(sizeof(string_cell) == sizeof(lisp_cell8));
   this = alloc_cell8(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_STRING, strlen(text));
   L_STRING_TEXT(this) = strdup(text);
   return this;
}

lptr make_static_string(lisp_env * env, const char *text)
{
   lptr this;

   assert(sizeof(string_cell) == sizeof(lisp_cell8));
   this = alloc_cell8(env);
   L_CAR(this) =
      L_MAKE_CELL_CAR(L_LISP_STRING, strlen(text)) | L_CELL_FLAG_STATIC;
   L_STRING_TEXT(this) = (char *) text;
   return this;
}


lptr make_list(lisp_env * env, ...)
{
   va_list ap;
   lptr first = Qnil;
   lptr last = Qnil;
   lptr curr;
   lptr arg;

   va_start(ap, env);
   while ((arg = va_arg(ap, lptr)) != Qvoid) {
      curr = make_cons(env, arg, Qnil);
      if (first == Qnil)
         first = curr;
      if (last != Qnil)
         L_CDR(last) = curr;
      last = curr;
   }
   va_end(ap);
   return first;
}

lptr make_symbol(lisp_env * env, lptr name, lptr value)
{
   lptr this;

   assert(sizeof(symbol_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SYMBOL, 0);
   L_SYMBOL_NEXT(this) = Qnil;
   L_SYMBOL_NAME(this) = name;
   L_SYMBOL_VALUE(this) = value;
   return this;
}

/* -------------------------------------------------------------------------------- */
/* interning */

lptr intern_symbol(lisp_env * env, lptr symbol, lptr obarray)
{
   size_t bucket;

   if (obarray == Qnil)
      obarray = env->obarray;

   assert(L_OBARRAYP(obarray));
   assert(L_SYMBOLP(symbol));

   bucket =
      lisp_hash(L_STRING_TEXT(L_SYMBOL_NAME(symbol))) %
      L_VECTOR_LENGTH(obarray);
   L_SYMBOL_NEXT(symbol) = L_VECTOR_CELL(obarray, bucket);
   L_VECTOR_CELL(obarray, bucket) = symbol;
   return symbol;
}

lptr find_symbol_by_name(lisp_env * env, const char *name, lptr obarray)
{
   size_t bucket;
   lptr symbol;

   if (obarray == Qnil)
      obarray = env->obarray;
   assert(L_OBARRAYP(obarray));

   bucket = lisp_hash(name) % L_VECTOR_LENGTH(obarray);
   for (symbol = L_VECTOR_CELL(obarray, bucket); symbol != Qnil;
      symbol = L_SYMBOL_NEXT(symbol)) {
      assert(L_SYMBOLP(symbol));
      assert(L_STRINGP(L_SYMBOL_NAME(symbol)));
      if (strcmp(L_STRING_TEXT(L_SYMBOL_NAME(symbol)), name) == 0)
         return symbol;
   }
   return Qnil;
}

lptr find_symbol(lisp_env * env, lptr symbol, lptr obarray)
{
   assert(L_SYMBOLP(symbol));
   assert(L_STRINGP(L_SYMBOL_NAME(symbol)));
   return find_symbol_by_name(env, L_STRING_TEXT(L_SYMBOL_NAME(symbol)),
      obarray);
}

lptr unintern_symbol(lisp_env * env, lptr symbol, lptr obarray)
{
   if (obarray == Qnil)
      obarray = env->obarray;
   assert(L_OBARRAYP(obarray));

   return Qnil;
}

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

lptr make_subr0(lisp_env * env, lptr name, lptr(*subr) (lisp_env *))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR0, 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 0) = subr;
   L_SUBR_MIN_ARGS(this) = 0;
   L_SUBR_MAX_ARGS(this) = 0;
   return this;
}

lptr make_subr1(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR1, elipsis ? 1 : 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 1) = subr;
   L_SUBR_MIN_ARGS(this) = min;
   L_SUBR_MAX_ARGS(this) = 1;
   return this;
}

lptr make_subr2(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR2, elipsis ? 1 : 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 2) = subr;
   L_SUBR_MIN_ARGS(this) = min;
   L_SUBR_MAX_ARGS(this) = 2;
   return this;
}

lptr make_subr3(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR3, elipsis ? 1 : 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 3) = subr;
   L_SUBR_MIN_ARGS(this) = min;
   L_SUBR_MAX_ARGS(this) = 3;
   return this;
}

lptr make_subr4(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr, lptr))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR4, elipsis ? 1 : 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 4) = subr;
   L_SUBR_MIN_ARGS(this) = min;
   L_SUBR_MAX_ARGS(this) = 4;
   return this;
}

lptr make_subr5(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr, lptr, lptr))
{
   lptr this;

   assert(sizeof(subr_cell) == sizeof(lisp_cell16));
   assert(L_STRINGP(name));

   this = alloc_cell16(env);
   L_CAR(this) = L_MAKE_CELL_CAR(L_LISP_SUBR5, elipsis ? 1 : 0);
   L_SUBR_NAME(this) = name;
   L_SUBR_FN(this, 5) = subr;
   L_SUBR_MIN_ARGS(this) = min;
   L_SUBR_MAX_ARGS(this) = 5;
   return this;
}

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

size_t lisp_hash(const char *text)
{
   register size_t hash;
   for (hash = 0; *text; ++text)
      hash = 37 * hash + *text;
   return hash;
}

#define l_assert(cond)                assert(cond)
#define l_assert_not(cond)        assert(!(cond))

lptr lisp_sanity_check(lisp_env * env)
{
#if 0
   lptr val;
   vp_printf("Running sanity check tests for LISP\n");
   l_assert_not(L_INTP(Qnil));
   l_assert_not(L_CELLP(Qnil));
   l_assert_not(L_CONSP(Qnil));
   l_assert_not(L_SPECIALP(Qnil));
   l_assert(L_NILP(Qnil));
   l_assert_not(L_pT(Qnil));
   l_assert(L_pLIST(Qnil));

   l_assert_not(L_pINT(Qt));
   l_assert_not(L_pCELL(Qt));
   l_assert_not(L_pCONS(Qt));
   l_assert_not(L_pSPECIAL(Qt));
   l_assert_not(L_pNIL(Qt));
   l_assert(L_pT(Qt));
   l_assert_not(L_pLIST(Qt));

   {
      int i;
      int integer[] = { 123, -123, 0, -1 };

      for (i = 0; i < sizeof integer / sizeof *integer; ++i) {
         vp_printf("Testing integer compatibility for %d\n", integer[i]);

         val = L_cINT(integer[i]);

         l_assert(L_pINT(val));
         l_assert_not(L_pCELL(val));
         l_assert_not(L_pCONS(val));
         l_assert_not(L_pSPECIAL(val));
         l_assert_not(L_pNIL(val));
         l_assert_not(L_pT(val));
         l_assert_not(L_pLIST(val));

         l_assert(L_gINT(val) == integer[i]);
      }
   }
#endif
   return Qnil;
}

#undef l_assert
#undef l_assert_not

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

lptr lprint(lisp_env * env, lptr val)
{
   if (val == Qnil) {
      fputs("nil", stdout);
      return val;
   }
   switch (L_TYPE(val)) {
   case L_LISP_CONS:
      lisp_print_list(env, val);
      break;
   case L_LISP_INT:
      printf("%lu", L_GET_INT(val));
      break;
   case L_LISP_STRING:
      printf("\"%s\"", L_STRING_TEXT(val));
      break;
   case L_LISP_VECTOR:
      lisp_print_vector(env, val);
      break;
   case L_LISP_VOID:
      fputs("void", stdout);
      break;
   case L_LISP_T:
      fputc('t', stdout);
      break;
   case L_LISP_SYMBOL:
      fputs(L_STRING_TEXT(L_SYMBOL_NAME(val)), stdout);
      break;
   case L_LISP_SF:
   case L_LISP_SUBR0:
   case L_LISP_SUBR1:
   case L_LISP_SUBR2:
   case L_LISP_SUBR3:
   case L_LISP_SUBR4:
   case L_LISP_SUBR5:
   case L_LISP_SUBRN:
      printf("<#subr %s>", L_STRING_TEXT(L_SUBR_NAME(val)));
      break;
   default:
      fprintf(stderr, "Cannot print that: %#2lx\n", L_TYPE(val));
      abort();
   }
   return val;
}

lptr lisp_print_vector(lisp_env * env, lptr val)
{
   size_t count = L_VECTOR_LENGTH(val);
   size_t i;
   fputc('[', stdout);
   for (i = 0; i < count - 1; ++i) {
      lprint(env, L_VECTOR_CELL(val, i));
      fputc(' ', stdout);
   }
   lprint(env, L_VECTOR_CELL(val, i));
   fputc(']', stdout);
   return val;
}

lptr lisp_print_list(lisp_env * env, lptr val)
{
   lptr cdr;
   fputc('(', stdout);
again:
   lprint(env, L_CAR(val));
   cdr = L_CDR(val);
   if (L_CONSP(cdr)) {
      val = cdr;
      fputc(' ', stdout);
      goto again;
   }
   if (cdr != Qnil) {
      fputs(" . ", stdout);
      lprint(env, cdr);
   }
   fputc(')', stdout);
   return val;
}

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

lptr lprinc(lisp_env * env, lptr val)
{
   if (val == Qnil) {
      fputs("nil", stdout);
      return val;
   }
   switch (L_TYPE(val)) {
   case L_LISP_CONS:
      lisp_princ_list(env, val);
      break;
   case L_LISP_INT:
      printf("%lu", L_GET_INT(val));
      break;
   case L_LISP_STRING:
      printf("%s", L_STRING_TEXT(val));
      break;
   case L_LISP_VECTOR:
      lisp_princ_vector(env, val);
      break;
   case L_LISP_VOID:
      fputs("void", stdout);
      break;
   case L_LISP_T:
      fputc('t', stdout);
      break;
   case L_LISP_SYMBOL:
      fputs(L_STRING_TEXT(L_SYMBOL_NAME(val)), stdout);
      break;
   case L_LISP_SF:
   case L_LISP_SUBR0:
   case L_LISP_SUBR1:
   case L_LISP_SUBR2:
   case L_LISP_SUBR3:
   case L_LISP_SUBR4:
   case L_LISP_SUBR5:
   case L_LISP_SUBRN:
      printf("<#subr %s>", L_STRING_TEXT(L_SUBR_NAME(val)));
      break;
   default:
      fprintf(stderr, "Cannot princ that\n");
      abort();
   }
   return val;
}

lptr lisp_princ_vector(lisp_env * env, lptr val)
{
   size_t count = L_VECTOR_LENGTH(val);
   size_t i;
   fputc('[', stdout);
   for (i = 0; i < count - 1; ++i) {
      lprinc(env, L_VECTOR_CELL(val, i));
      fputc(' ', stdout);
   }
   lprinc(env, L_VECTOR_CELL(val, i));
   fputc(']', stdout);
   return val;
}

lptr lisp_princ_list(lisp_env * env, lptr val)
{
   lptr cdr;
   fputc('(', stdout);
again:
   lprinc(env, L_CAR(val));
   cdr = L_CDR(val);
   if (L_CONSP(cdr)) {
      val = cdr;
      fputc(' ', stdout);
      goto again;
   }
   if (cdr != Qnil) {
      fputs(" . ", stdout);
      lprinc(env, cdr);
   }
   fputc(')', stdout);
   return val;
}

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

lptr lisp_read(lisp_env * env, struct lisp_stream * stream)
{
   char token[4096];
   char *token_p = token;
   int c;
   lptr result;

read_char:
   c = stream->read(stream);
   /* printf ("read: %c\n", c); */
   switch (c) {

   case -1:
      return Qvoid;

   case '\n':
   case '\t':
   case '\v':
   case ' ':
      goto read_char;

   case ';':
      lisp_read_comment(env, stream);
      goto read_char;

   case '\'':
      return make_list(env, find_symbol_by_name(env, "quote", Qnil),
         lisp_read(env, stream), Qvoid);

   case '(':
      result = lisp_read_list(env, stream);
      return result;

   case ')':
      stream->unget(stream, c); /* tell list reader we've found the closing bracket */
      return Qvoid;

   case '.':
      stream->unget(stream, c); /* tell list reader we've found the dot */
      return Qvoid;

   case '"':
      result = lisp_read_string(env, stream);
      if (result == Qvoid)
         goto read_char;
      else
         return result;

   case '\\':
      c = stream->read(stream);
      switch (c) {
      case -1:
         fprintf(stderr, "End of file error");
         abort();
      case 'n':
         c = '\n';
         break;
      case 't':
         c = '\t';
         break;
      }
      goto accumulate;

   case '?':
      c = stream->read(stream);
      return L_MAKE_INT(c);

   case '0': case '1': case '2': case '3': case '4':
   case '5': case '6': case '7': case '8': case '9':
   case '-':
   case '*':
   case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g':
   case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n':
   case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u':
   case 'v': case 'w': case 'x': case 'y': case 'z': 
   case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G':
   case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N':
   case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U':
   case 'V': case 'W': case 'X': case 'Y': case 'Z': 
      goto accumulate;

   default:
      goto fail;
   }
accumulate:
   /* printf ("accumulate: %c\n", c); */
   *token_p++ = c;
   for (;;) {
      c = stream->read(stream);
      /* printf ("accumulate: %c\n", c); */
      if (c == -1)
         goto interpret;
      else if (ascii_isspace(c))
         goto interpret;
      else if (strchr("()[]", c)) {
         stream->unget(stream, c);
         goto interpret;
      } else
         if (strchr
         ("-+*.0123456789qwwertyuiopasdfghjklzxcvbnmQWERTYUIOPASDFGHJKLZXCVBNM",
            c))
         *token_p++ = c;
      else
         goto fail;
   }
interpret:
   /* printf ("interpreting_token\n"); */
   if (token_p == token)
      return Qvoid;
   else {
      *token_p++ = 0;
      if ((token[0] == '-' || token[0] == '+')
         && strspn(token + 1, "0123456789") == strlen(token + 1))
         return lisp_parse_int(env, token);
      else
         return lisp_parse_symbol(env, token);
   }
fail:
   fprintf(stderr, "aborting on char: '%c' (%d)\n", c, c);
   abort();

   return Qvoid;
}

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

lptr lisp_read_string(lisp_env * env, struct lisp_stream * stream)
{
   char buf[4096];
   char *str = buf;
   int c;
   for (;;)
      switch (c = stream->read(stream)) {
      case -1:
         fprintf(stderr, "Unterminated string constant\n");
         abort();
      case '"':
         *str++ = 0;
         return make_string(env, buf);
      case '\n':
         fprintf(stderr, "Warning: newline in string\n");
         *str++ = c;
         break;
      case '\\':
         c = stream->read(stream);
         switch (c) {
         case 'n':
            c = '\n';
            break;
         case 't':
            c = '\t';
            break;
         }
      default:
         *str++ = c;
         break;
      }
}

lptr lisp_read_list(lisp_env * env, struct lisp_stream *stream)
{
   lptr first = Qnil;
   lptr last = Qnil;
   lptr curr = Qnil;
   lptr item;

   for (;;) {
      item = lisp_read(env, stream);
      if (item == Qvoid) {
         switch (stream->read(stream)) {
         case ')':
            goto done;
         case '.':
            if (curr != Qnil) {
               L_CDR(curr) = lisp_read(env, stream);
               goto done;
            } else {
               fprintf(stderr, "Illegal syntax\n");
               abort();
            }
         default:
            fprintf(stderr, "Error: missing )\n");
            abort();
         }
      } else {
         curr = make_cons(env, item, Qnil);
         if (last != Qnil)
            L_CDR(last) = curr;
         else
            first = curr;
         last = curr;
      }
   }
done:
   return first;
}

lptr lisp_read_comment(lisp_env * env, struct lisp_stream * stream)
{
   int c;
   do {
      c = stream->read(stream);
   }
   while (c != '\n' && c != -1);
   return Qnil;
}

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

lptr lisp_parse_int(lisp_env * env, char *token)
{
   int int_val = atoi(token);
   return L_MAKE_INT(int_val);
}

lptr lisp_parse_symbol(lisp_env * env, char *token)
{
   if (0 == strcmp(token, "nil"))
      return Qnil;
   else if (0 == strcmp(token, "t"))
      return Qt;
   else {
      lptr symbol = find_symbol_by_name(env, token, Qnil);
      if (symbol != Qnil)
         return symbol;
      symbol = make_symbol(env, make_string(env, token), Qvoid);
      intern_symbol(env, symbol, Qnil);
      return symbol;
   }
}

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

lptr lisp_eval_args(lisp_env * env, lptr arg_list)
{
   lptr first = Qnil;
   lptr last = Qnil;
   lptr curr;
   lptr arg;

   for (arg = arg_list; arg != Qnil; arg = L_CDR(arg)) {
      curr = make_cons(env, leval(env, L_CAR(arg)), Qnil);
      if (first == Qnil)
         first = curr;
      if (last != Qnil)
         L_CDR(last) = curr;
      last = curr;
   }
   return first;
}

lptr lisp_funcall(lisp_env * env, lptr fun, lptr arg_list)
{
   int i;
   lptr this_arg;
   lptr arg[5] = { Qnil, Qnil, Qnil, Qnil, Qnil };
   lptr rest = Qnil;
   int min_args;
   int max_args;
   bool elipsis;
   size_t type;

   assert(L_SUBRP(fun));

   min_args = L_SUBR_MIN_ARGS(fun);
   max_args = L_SUBR_MAX_ARGS(fun);
   elipsis = L_SUBR_ELIPSIS(fun);
   type = L_CELL_TYPE(fun);

   if (elipsis)
      max_args--;


   /* evaluate all required arguments */
   for (i = 0, this_arg = arg_list; i < max_args && this_arg != Qnil;
      ++i, this_arg = L_CDR(this_arg))
      arg[i] = leval(env, L_CAR(this_arg));

   /* check the lower limit */
   if (i < min_args) {
      fprintf(stderr, "The function %s requires at least %d arguments\n",
         L_STRING_TEXT(L_SUBR_NAME(fun)), min_args);
      return Qnil;
   }
   if (elipsis) {
      /* if we accept elipsis consume all remaining arguments and evaluate them */
      rest = lisp_eval_args(env, this_arg);
   } else if (this_arg != Qnil) {
      /* otherwise check the upper limit */
      fprintf(stderr, "The function %s accepts at most %d arguments\n",
         L_STRING_TEXT(L_SUBR_NAME(fun)), max_args);
      return Qnil;
   }

   if (elipsis)
      switch (type) {
      case L_LISP_SUBR1:
         return L_SUBR_FN(fun, 1) (env, rest);
      case L_LISP_SUBR2:
         return L_SUBR_FN(fun, 2) (env, arg[0], rest);
      case L_LISP_SUBR3:
         return L_SUBR_FN(fun, 3) (env, arg[0], arg[1], rest);
      case L_LISP_SUBR4:
         return L_SUBR_FN(fun, 4) (env, arg[0], arg[1], arg[2], rest);
      case L_LISP_SUBR5:
         return L_SUBR_FN(fun, 5) (env, arg[0], arg[1], arg[2], arg[3], rest);
      default:
         abort();
   } else
      switch (type) {
      case L_LISP_SUBR0:
         return L_SUBR_FN(fun, 0) (env);
      case L_LISP_SUBR1:
         return L_SUBR_FN(fun, 1) (env, arg[0]);
      case L_LISP_SUBR2:
         return L_SUBR_FN(fun, 2) (env, arg[0], arg[1]);
      case L_LISP_SUBR3:
         return L_SUBR_FN(fun, 3) (env, arg[0], arg[1], arg[2]);
      case L_LISP_SUBR4:
         return L_SUBR_FN(fun, 4) (env, arg[0], arg[1], arg[2], arg[3]);
      case L_LISP_SUBR5:
         return L_SUBR_FN(fun, 5) (env, arg[0], arg[1], arg[2], arg[3],
            arg[4]);
      default:
         abort();
      }
   abort();
}

lptr leval(lisp_env * env, lptr val)
{
   size_t type;

   if (val == Qnil)
      return val;

   type = L_TYPE(val);
   switch (type) {
   case L_LISP_CONS:
      {
         lptr calee = leval(env, L_CAR(val));
         lptr rest = L_CDR(val);
         /* printf ("Calle type: %s (%#02x)\n", lisp_type_name (calee), L_TYPE (calee)); */
         if (L_SUBRP(calee))
            return lisp_funcall(env, calee, rest);
         else
            return Qnil;
      }
   case L_LISP_VOID:
      fprintf(stderr, "error - evaluation of void value\n");
      abort();
      break;
   case L_LISP_SYMBOL:
      return L_SYMBOL_VALUE(val);
   case L_LISP_STRING:
   case L_LISP_VECTOR:
   case L_LISP_T:
   case L_LISP_INT:
   case L_LISP_SUBR0:
   case L_LISP_SUBR1:
   case L_LISP_SUBR2:
   case L_LISP_SUBR3:
   case L_LISP_SUBR4:
   case L_LISP_SUBR5:
   case L_LISP_SUBRN:
   case L_LISP_SF:
      return val;
   default:
      fprintf(stderr, "Cannot eval that: %2zx\n", type);
      abort();
   }
   return val;
}

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

const char *lisp_type_name(lptr val)
{
   if (val == Qnil)
      return "nil";
   switch (L_TYPE(val)) {
   case L_LISP_CONS:
      return "cons cell";
   case L_LISP_INT:
      return "integer";
   case L_LISP_STRING:
      return "string";
   case L_LISP_VECTOR:
      return "vector";
   case L_LISP_VOID:
      return "void";
   case L_LISP_T:
      return "t";
   case L_LISP_SYMBOL:
      return "symbol";
   case L_LISP_SF:
      return "special form";
   case L_LISP_SUBR0:
   case L_LISP_SUBR1:
   case L_LISP_SUBR2:
   case L_LISP_SUBR3:
   case L_LISP_SUBR4:
   case L_LISP_SUBR5:
   case L_LISP_SUBRN:
      return "subr";
   default:
      return "unknown";
   }
}
