/*
 * 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.
 */

#ifndef HAVE_LISP_H
#define HAVE_LISP_H

/* Lisp Implementation Supporting Poliqarp :-) */

#include <poliqarp-config.h>

#include <stdarg.h>

#include <sakura/common/memory-arena.h>

/* lisp pointer */
typedef unsigned long lptr;

/* lisp enviroment */
typedef struct lisp_env
{
   lptr flist8;
   lptr flist16;
   lptr obarray;                /* a vector really */
   struct marena cell_arena;
   struct marena misc_arena;

   struct
   {
      lptr common_glue;
      lptr auto_newline;
   } globals;

   void *user_data;

} lisp_env;

typedef struct lisp_cell8
{
   lptr car;
   lptr cdr;
} lisp_cell8;

typedef struct lisp_cell16
{
   lisp_cell8 slot1;
   lisp_cell8 slot2;
} lisp_cell16;

#include "lisp-stream.h"


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

/* non-cons cell structures (a little bit similar to librep's idea :P)
 * note that the least significant bit is always set */

/*
 *          Non-Cons Cell Car Description
 * ┌----[high bits XX(*)-8]-+-----[low bits]-----|
 * |  <extra cell storage>  |  7 6 5 4 3 2 1 0   |
 * |------------------------+--+-+-+-+-+-+-+-+---+
 *                             | | | | | | | |
 *   garbage collector flag __/  | | | | | |  \____ always set
 *   static storage flag    ____/  ^ | | | |
 *   wide cell (16) flag    ______/| | | | |
 *                                 | | | | |
 *                ________________/ / / / /
 *     type tag  /  _______________/ / / /
 *   described below _______________/ / /
 *               \ \_________________/ /
 *                \___________________/
 *
 * --------------------------------------
 *    *XX depends on architecture
 */

#define L_OBARRAY_SIZE                597
#define L_MASK(n_bits)                ((1L<<(n_bits))-1)
#define L_FLAG(bit_num)                (1L<<(bit_num))

#define L_TAG_WIDTH                2
#define L_CELL_TAG_WIDTH        8
#define L_TAG_MASK                L_MASK(L_TAG_WIDTH)
#define L_CELL_TYPE_MASK        L_MASK(6)       /* show cell type                */
#define L_CELL_FLAG_GC                L_FLAG(7) /* cell is marked                */
#define L_CELL_FLAG_STATIC        L_FLAG(6)     /* cell is somehow static        */
#define L_CELL_FLAG_WIDE        L_FLAG(5)       /* cell is cell16                */

#define L_FLAG_INT                L_FLAG(1)     /* lptr is an integer                */
#define L_FLAG_NEGATIVE                L_FLAG(sizeof (lptr) * CHAR_BIT - 1)     /* lptr is negative (integer)        */
#define L_FLAG_NINT                (L_FLAG_INT|L_FLAG_NEGATIVE) /* lptr is a negatie integer        */
#define L_FLAG_GC                L_FLAG(0)      /* lptr is marked                */

/* TAGS */
#define L_LISP_CONS                0x00 /* cons cell        (tag)                        */
#define L_LISP_INT                0x02  /* integer        (tag)                        */
/* SHORT CELLS */
#define L_LISP_STRING                0x01       /* string cell                                */
#define L_LISP_VECTOR                0x03       /* vector cell                                */
#define L_LISP_BITVECTOR        0x05    /* bit-vector                                */
#define L_LISP_COMPILED                0x07     /* compiled bytecode                        */
#define L_LISP_OBARRAY                0x09      /* obarray                                */
#define L_LISP_RESERVED_B1        0x0B
#define L_LISP_RESERVED_B2        0x0D
#define L_LISP_RESERVED_B3        0x0F
/* special purpose cells (short string cells accualy) */
#define L_LISP_VOID                0x11 /* (static void cell)                        */
#define L_LISP_ERROR                0x13        /* (static error cell)                        */
#define L_LISP_UNDEFINED        0x15    /* (static undefined cell)                */
#define L_LISP_T                0x17    /* (static true symbol)                        */
#define L_LISP_RESERVED_S1        0x19
#define L_LISP_RESERVED_S2        0x1B
#define L_LISP_RESERVED_S3        0x1D
#define L_LISP_RESERVED_S4        0x1F
/* WIDE CELLS */
#define L_LISP_SYMBOL                0x21       /* symbol cell                                */
#define L_LISP_RESERVED                0x23     /* closures                                */
/* a kind-of-subr but with different mask */
#define L_LISP_SF                0x25   /* special form                                */
/* subr cells note that mask 0x30 designates subr */
#define L_LISP_SUBR0                0x31        /* subr with no arguments                */
#define L_LISP_SUBR1                0x33        /* subr with one argument                */
#define L_LISP_SUBR2                0x35        /* subr with two arguments                */
#define L_LISP_SUBR3                0x37        /* subr with three arguments                */
#define L_LISP_SUBR4                0x39        /* subr with four arguments                */
#define L_LISP_SUBR5                0x3B        /* subr with five arguments                */
#define L_LISP_SUBRN                0x3D        /* subroutine with argument list        */


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

/* create special cell CAR signature */
#define L_MAKE_CELL_CAR(type,extra)        ((type)|((extra)<<L_CELL_TAG_WIDTH))

#define Qnil                        ((lptr)(0<<L_TAG_WIDTH))
#define L_NILP(ptr)                ((ptr)==Qnil)

#define L_VALUE(ptr)                ((ptr)>>L_TAG_WIDTH)
#define L_INTP(ptr)                (L_FLAG_INT&(ptr))
#define L_MAKE_INT(val)                (((val)<0?(-((val))<<L_TAG_WIDTH)|L_FLAG_NINT:((val)<<L_TAG_WIDTH)) | L_FLAG_INT)
#define L_GET_INT(ptr)                (                                                                \
                                        ((ptr) & L_FLAG_NINT ) == L_FLAG_NINT ?                        \
                                        - (L_VALUE (L_FLAG_NINT ^ (ptr) ) ) :                        \
                                        L_VALUE (ptr)                                                \
                                        )

typedef struct lisp_cell
{
   lptr car;
} lisp_cell;

#define L_CAR(ptr)                (((lisp_cell*)(ptr))->car)
#define L_EXTRA(ptr)                (L_CAR(ptr)>>L_CELL_TAG_WIDTH)

typedef struct lisp_cons
{
   lptr car;
   lptr cdr;
} lisp_cons;

#define L_CDR(ptr)                (((lisp_cons*)(ptr))->cdr)
#define L_GCDR(ptr)                (((lisp_cons*)(ptr))->cdr & ~L_FLAG_GC)

#define L_CELL_CONSP(ptr)        ((L_CAR(ptr) & 1) == 0)
#define L_CONSP(ptr)                (L_CELLP(ptr) && L_CELL_CONSP(ptr))
#define L_LISTP(ptr)                (L_NILP(ptr) || L_CONSP(ptr))

#define L_CELLP(ptr)                (!L_INTP(ptr) && !L_NILP(ptr))
#define L_CELL_TYPE(ptr)        (L_CAR(ptr) & L_CELL_TYPE_MASK)
#define L_CELL_TYPEP(ptr,type)        (L_CELL_TYPE(ptr) == L_LISP_ #type)
#define L_TYPE(ptr)                (L_INTP(ptr) ? L_LISP_INT : L_CELL_CONSP(ptr) ? L_LISP_CONS : L_CELL_TYPE(ptr))
#define L_TYPEP(ptr,type)        (L_TYPE(ptr) == L_LISP_ ##type)

typedef struct string_cell
{
   lptr car;                    /* extra bits == string length */
   char *text;
} string_cell;

#define L_STRINGP(ptr)                L_TYPEP(ptr, STRING)
#define L_STRING_LENGTH(ptr)        L_EXTRA(ptr)
#define L_STRING_TEXT(ptr)        (((string_cell *)(ptr))->text)

typedef struct vector_cell
{
   lptr car;                    /* extra bits == vector size */
   lptr *cell;
} vector_cell;

#define L_VECTORP(ptr)                L_TYPEP(ptr, VECTOR)
#define L_OBARRAYP(ptr)                L_TYPEP(ptr, OBARRAY)
#define L_VECTOR_LENGTH(ptr)        L_EXTRA(ptr)
#define L_VECTOR_FIELD(ptr,f)        (((vector_cell *)(ptr))->f)
#define L_VECTOR_CELL(ptr,i)        L_VECTOR_FIELD(ptr, cell[i])
#define L_VECTOR_CELLS(ptr)        L_VECTOR_FIELD(ptr, cell)

typedef struct subr_cell
{
   lptr car;                    /* extra bits == elipsis */
   lptr name;                   /* string  cell */
   union
   {
      lptr(*fn0) (lisp_env *);
      lptr(*fn1) (lisp_env *, lptr);
      lptr(*fn2) (lisp_env *, lptr, lptr);
      lptr(*fn3) (lisp_env *, lptr, lptr, lptr);
      lptr(*fn4) (lisp_env *, lptr, lptr, lptr, lptr);
      lptr(*fn5) (lisp_env *, lptr, lptr, lptr, lptr, lptr);
   } as;
   int16_t min_args;
   int16_t max_args;
} subr_cell;

#define L_SUBR_MASK                        (L_FLAG(5)|L_FLAG(4))
#define L_SFP(ptr)                        L_TYPEP(ptr, SF)
#define L_SUBRP(ptr)                        (L_CELLP(ptr) && ((L_CAR(ptr) & L_SUBR_MASK) == L_SUBR_MASK))
#define L_CELL_SUBRP(ptr)                ((L_CAR(ptr) & L_SUBR_MASK) == L_SUBR_MASK)
#define L_SUBR_FIELD(ptr,field)                (((subr_cell*)(ptr))->field)
#define L_SUBR_NAME(ptr)                L_SUBR_FIELD(ptr, name)
#define L_SUBR_FN(ptr,N)                L_SUBR_FIELD(ptr, as.fn ## N)
#define L_SUBR_MIN_ARGS(ptr)                L_SUBR_FIELD(ptr, min_args)
#define L_SUBR_MAX_ARGS(ptr)                L_SUBR_FIELD(ptr, max_args)
#define L_SUBR_ELIPSIS(ptr)                L_EXTRA(ptr)

typedef struct symbol_cell
{
   lptr car;                    /* extra bits == unused */
   lptr next;                   /* points at another symbol in the same obarray */
   lptr name;                   /* this really *must* be a string cell or dragons will come */
   lptr value;                  /* value stored here */
} symbol_cell;

#define L_SYMBOLP(ptr)                        L_TYPEP(ptr, SYMBOL)
#define L_SYMBOL_FIELD(ptr,field)        (((symbol_cell*)(ptr))->field)
#define L_SYMBOL_NEXT(ptr)                L_SYMBOL_FIELD(ptr,next)
#define L_SYMBOL_NAME(ptr)                L_SYMBOL_FIELD(ptr,name)
#define L_SYMBOL_VALUE(ptr)                L_SYMBOL_FIELD(ptr,value)

typedef struct special_cell
{
   lptr car;
   char *text;
} special_cell;

#define L_SPECIAL_MASK                        L_FLAG(4)
#define L_SPECIALP(ptr)                        (L_CELLP(ptr) && (L_CAR(ptr) & L_SPECIAL_MASK))
#define L_SPECIAL_FIELD(ptr,field)        (((special_cell*)(ptr))->field)
#define L_SPECIAL_TYPE(ptr)                L_EXTRA (ptr)
#define L_SPECIAL_TEXT(ptr)                L_SPECIAL_FIELD(ptr, text)

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

#define DEF_SPECIAL(name,type)                                                \
                special_cell V ## name = { L_MAKE_CELL_CAR(type, 0) };        \
                lptr Q ## name = (lptr)& V ## name;

#define EX_DEF_SPECIAL(type)                                                \
                extern special_cell V ## type;                                \
                extern lptr Q ## type

EX_DEF_SPECIAL(t);
EX_DEF_SPECIAL(void);
EX_DEF_SPECIAL(undefined);
EX_DEF_SPECIAL(error);

/* -------------------------------------------------------------------------------- */
/* -------------------------------------------------------------------------------- */
/* enviroment handling */

lisp_env *make_lisp_env(void);
void free_lisp_env(lisp_env * env);

void lisp_set_user_data(lisp_env * env, void *data);
void *lisp_get_user_data(lisp_env * env);

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

lptr alloc_cell8(lisp_env * env);
lptr alloc_cell16(lisp_env * env);
void free_cell8(lisp_env * env, lptr this);
void free_cell16(lisp_env * env, lptr this);

/* -------------------------------------------------------------------------------- */
/* creation routines */

lptr make_cons(lisp_env * env, lptr car, lptr cdr);
lptr make_list(lisp_env * env, ...);
lptr make_vector(lisp_env * env, size_t size);
lptr make_obarray(lisp_env * env, size_t size);
lptr make_string(lisp_env * env, const char *text);
lptr make_static_string(lisp_env * env, const char *text);
lptr make_symbol(lisp_env * env, lptr name, lptr value);

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

lptr find_symbol_by_name(lisp_env * env, const char *name, lptr obarray);
lptr intern_symbol(lisp_env * env, lptr symbol, lptr obarray);
lptr find_symbol(lisp_env * env, lptr symbol, lptr obarray);
lptr unintern_symbol(lisp_env * env, lptr symbol, lptr obarray);

/* -------------------------------------------------------------------------------- */
/* subroutines */

lptr make_subr0(lisp_env * env, lptr name, lptr(*subr) (lisp_env *));
lptr make_subr1(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr));
lptr make_subr2(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr));
lptr make_subr3(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr));
lptr make_subr4(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr, lptr));
lptr make_subr5(lisp_env * env, lptr name, int16_t min, bool elipsis,
   lptr(*subr) (lisp_env *, lptr, lptr, lptr, lptr, lptr));

#define L_DEF_SUBR(_env_, _name_, min_args, max_args, fn) do {                        \
    lptr name = make_static_string (_env_, _name_);                                \
    lptr subr = make_subr ## max_args (_env_, name, min_args, false, fn);        \
    lptr symbol = make_symbol (_env_, name, subr);                                \
    intern_symbol (_env_, symbol, Qnil);                                        \
} while (0)

#define L_DEF_SUBRX(_env_, _name_, min_args, max_args, fn) do {                        \
    lptr name = make_static_string (_env_, _name_);                                \
    lptr subr = make_subr ## max_args (_env_, name, min_args, true, fn);        \
    lptr symbol = make_symbol (_env_, name, subr);                                \
    intern_symbol (_env_, symbol, Qnil);                                        \
} while (0)
/* -------------------------------------------------------------------------------- */
/* misc routines */

size_t lisp_hash(const char *text);
lptr lisp_sanity_check(lisp_env * env);

/* -------------------------------------------------------------------------------- */
/* printing routines */

lptr lprint(lisp_env * env, lptr val);  /* print in lisp-readable format */
lptr lisp_print_vector(lisp_env * env, lptr val);
lptr lisp_print_list(lisp_env * env, lptr val);

lptr lprinc(lisp_env * env, lptr val);  /* print in human readable format */
lptr lisp_princ_vector(lisp_env * env, lptr val);
lptr lisp_princ_list(lisp_env * env, lptr val);

/* -------------------------------------------------------------------------------- */
/* reading routines */

lptr lisp_read(lisp_env * env, struct lisp_stream *stream);

/* -------------------------------------------------------------------------------- */
/* reading sub-routines */

lptr lisp_read_string(lisp_env * env, struct lisp_stream *stream);
lptr lisp_read_comment(lisp_env * env, struct lisp_stream *stream);
lptr lisp_read_list(lisp_env * env, struct lisp_stream *stream);
lptr lisp_read_vector(lisp_env * env, struct lisp_stream *stream);

/* -------------------------------------------------------------------------------- */
/* parsing routines */

lptr lisp_parse_int(lisp_env * env, char *token);
lptr lisp_parse_symbol(lisp_env * env, char *token);

/* -------------------------------------------------------------------------------- */
/* evaluation routines */
lptr leval(lisp_env * env, lptr val);

/* -------------------------------------------------------------------------------- */
/* misc */
const char *lisp_type_name(lptr val);

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

#endif /* HAVE_LISP_H */
