/*
Copyright (C) 2005-2007, The Perl Foundation.
$Id: luatable.pmc 22933 2007-11-21 19:40:01Z paultcochrane $

=head1 NAME

pmc/luatable.pmc - Lua Table

=head1 DESCRIPTION

C<LuaTable> extends C<LuaBase> to provide a class with the behaviour of
the Lua C<Table> type.

This implementation is based on the Lua 4.0 one.

=head2 Overloaded Methods

=over 4

=cut

*/

#include "lua_private.h"

#define LUA_ASSERT(c, s)         assert(((void)s, (c)))

#define Hash LuaHash

#define MAX_INT (INT_MAX-2)  /* maximum value of an int (-2 for safety) */

#define MINPOWER2       4       /* minimum size for "growing" vectors */


/******************************************************************************/

/*
** Implementation of tables (aka arrays, objects, or hash tables);
** uses a mix of chained scatter table with Brent's variation.
** A main invariant of these tables is that, if an element is not
** in its main position (i.e. the `original' position that its hash gives
** to it), then the colliding element is in its own main position.
** In other words, there are collisions only when two elements have the
** same main position (i.e. the same hash values for that table size).
** Because of that, the load factor of these tables can be 100% without
** performance penalties.
*/

typedef struct Node {
    PMC *key;
    PMC *val;
    struct Node *next;  /* for chaining */
} Node;

typedef struct Hash {
    Node *node;
    int size;
    Node *firstfree;  /* this position is free; all positions after it are full */
    PMC *container;
} Hash;

#define node(t, i)       (&(t)->node[i])

/******************************************************************************/

static int lua_equalObj(PARROT_INTERP, const PMC *t1, const PMC *t2)
{
    if (NULL == t2)
        return 0;
    if (PMC_type(t1) != PMC_type(t2))
        return 0;
    if (PMC_type(t1) == dynpmc_LuaNumber)
        return PMC_num_val(t1) == PMC_num_val(t2);
    if (PMC_type(t1) == dynpmc_LuaBoolean)
        return PMC_int_val(t1) == PMC_int_val(t2);
    if (PMC_type(t1) == dynpmc_LuaString)
        return 0 == string_compare(interp, PMC_str_val(t1), PMC_str_val(t2));
    return PMC_struct_val(t1) == PMC_struct_val(t2);
}

/*
** returns the `main' position of an element in a table (that is, the index
** of its hash value)
*/
static Node *mainposition(PARROT_INTERP, const Hash *t, const PMC *key)
{
    unsigned long h;
    if (PMC_type(key) == dynpmc_LuaNil) {
        return NULL;
    }
    if (PMC_type(key) == dynpmc_LuaNumber) {
        h = (unsigned long)(long)PMC_num_val(key);
    }
    else if (PMC_type(key) == dynpmc_LuaBoolean) {
        h = PMC_int_val(key);
    }
    else if (PMC_type(key) == dynpmc_LuaString) {
        h = string_hash(interp, PMC_str_val(key), 3793);
        /* h = PMC_str_val(key)->hashval; */
    }
    else {
        h = (unsigned long)PMC_struct_val(key);
        h >>= 3;
    }
    LUA_ASSERT(h%(unsigned int)t->size == (h&((unsigned int)t->size-1)),
               "a&(x-1) == a%x, for x power of 2");
    return &t->node[h&(t->size-1)];
}

/* specialized version for strings */
static PMC** lua_getstr(PARROT_INTERP, const Hash *t, STRING *key)
{
    unsigned long h = string_hash(interp, key, 3793);
    Node *n = &t->node[h&(t->size-1)];
    do {
        if (PMC_type(n->key) == dynpmc_LuaString
            && 0 == string_compare(interp, PMC_str_val(n->key), key))
            return &n->val;
        n = n->next;
    } while (n);
    return NULL;  /* key not found */
}

static PMC** lua_get(PARROT_INTERP, const Hash *t, const PMC* key)
{
    Node *n = mainposition(interp, t, key);
    if (n == NULL)
        return NULL;
    do {
        if (lua_equalObj(interp, key, n->key))
            return &n->val;
        n = n->next;
    } while (n);
    return NULL;  /* key not found */
}

static Node* lua_next(PARROT_INTERP, const Hash *t, const PMC *key)
{
    int i;
    if (key == NULL || PMC_type(key) == dynpmc_LuaNil)
        i = 0;  /* first iteration */
    else {
        PMC **v = lua_get(interp, t, key);
        if (NULL == v || NULL == *v)
            real_exception(interp, NULL, 1, "invalid key to 'next'");
        i = (int)(((const char *)v -
                   (const char *)(&t->node[0].val)) / sizeof (Node)) + 1;
    }
    for (; i<t->size; i++) {
        Node *n = node(t, i);
        if (n->val != NULL)
            return n;
    }
    return NULL;  /* no more elements */
}

static void rehash(PARROT_INTERP, Hash *t);

/*
** inserts a key into a hash table; first, check whether key is
** already present; if not, check whether key's main position is free;
** if not, check whether colliding node is in its main position or not;
** if it is not, move colliding node to an empty place and put new key
** in its main position; otherwise (colliding node is in its main position),
** new key goes to an empty position.
*/
static PMC** lua_set(PARROT_INTERP, Hash *t, PMC* key)
{
    Node *mp = mainposition(interp, t, key);
    Node *n = mp;
    if (NULL == mp) {
        real_exception(interp, NULL, 1, "table index is nil");
        return NULL;
    }
    do {  /* check whether `key' is somewhere in the chain */
        if (lua_equalObj(interp, key, n->key))
            return &n->val;  /* that's all */
        else n = n->next;
    } while (n);
    /* `key' not found; must insert it */
    if (mp->key != NULL) {  /* main position is not free? */
        Node *othern;  /* main position of colliding node */
        n = t->firstfree;  /* get a free place */
        /* is colliding node out of its main position? (can only happens if
           its position is after "firstfree") */
        if (mp > n && (othern=mainposition(interp, t, mp->key)) != mp) {
            /* yes; move colliding node into free position */
            while (othern->next != mp) othern = othern->next;  /* find previous */
            othern->next = n;  /* redo the chain with `n' in place of `mp' */
            *n = *mp;  /* copy colliding node into free pos. (mp->next also goes) */
            mp->next = NULL;  /* now `mp' is free */
        }
        else {  /* colliding node is in its own main position */
            /* new node will go into free position */
            n->next = mp->next;  /* chain new position */
            mp->next = n;
            mp = n;
        }
    }
    mp->key = key;
    for (;;) {  /* correct `firstfree' */
        if (NULL == t->firstfree->key)
            return &mp->val;  /* OK; table still has a free place */
        else if (t->firstfree == t->node) break;  /* cannot decrement from here */
        else (t->firstfree)--;
    }
    rehash(interp, t);  /* no more free places */
    return lua_set(interp, t, key);  /* `rehash' invalidates this insertion */
}

static void setnodevector(PARROT_INTERP, Hash *t, int size)
{
    int i;
    if (size > MAX_INT)
        real_exception(interp, NULL, 1, "table overflow");
    t->node = mem_sys_allocate_zeroed(size * sizeof (Node));
    t->size = size;
    t->firstfree = &t->node[size-1];  /* first free position to be used */
}

static int numuse(const Hash *t) {
    Node *v = t->node;
    int size = t->size;
    int realuse = 0;
    int i;
    for (i=0; i<size; i++) {
        if (v[i].val != NULL)
            realuse++;
    }
    return realuse;
}

static void rehash(PARROT_INTERP, Hash *t)
{
    int oldsize = t->size;
    Node *nold = t->node;
    int nelems = numuse(t);
    int i;
    LUA_ASSERT(nelems<=oldsize, "wrong count");
    Parrot_block_DOD(interp);
    if (nelems >= oldsize-oldsize/4)  /* using more than 3/4? */
        setnodevector(interp, t, oldsize*2);
    else if (nelems <= oldsize/4 &&  /* less than 1/4? */
             oldsize > MINPOWER2)
        setnodevector(interp, t, oldsize/2);
    else
        setnodevector(interp, t, oldsize);
    for (i=0; i<oldsize; i++) {
        Node *old = nold+i;
        if (old->val != NULL)
            *lua_set(interp, t, old->key) = old->val;
    }
    Parrot_unblock_DOD(interp);
    mem_sys_free(nold);  /* free old array */
}

static void lua_new_table(PARROT_INTERP, PMC *container)
{
    Hash * const t = mem_allocate_zeroed_typed(Hash);
    PMC_struct_val(container) = t;
    t->container = container;
    setnodevector(interp, t, MINPOWER2);
}

static void lua_destroy_table(PARROT_INTERP, Hash *t)
{
    mem_sys_free(t->node);
    mem_sys_free(t);
}

static void lua_mark_table(PARROT_INTERP, Hash *t, STRING *mode)
{
    Node *v = t->node;
    int i;
    int mark_key = 1;
    int mark_val = 1;
    if (mode) {
        mark_key = string_str_index(interp, mode, const_string(interp, "k"), 0) < 0;
        mark_val = string_str_index(interp, mode, const_string(interp, "v"), 0) < 0;
    }
    for (i = 0; i < t->size; i++) {
        if (v[i].val != NULL) {
            if (mark_key)
                pobject_lives(interp, (PObj *)v[i].key);
            if (mark_val)
                pobject_lives(interp, (PObj *)v[i].val);
        }
    }
}


pmclass LuaTable
    extends LuaAny
    does hash
    dynpmc
    need_ext
    group lua_group
    hll Lua {

/*

=item C<void init()>

Initializes the instance.

=cut

*/
    void init() {
        PMC_struct_val(SELF) = NULL;
        PMC_metadata(SELF) = NULL;
        PObj_custom_mark_destroy_SETALL(SELF);
        lua_new_table(INTERP, SELF);
    }

/*

=item C<void mark()>

Marks the hash as live.

=cut

*/
    void mark() {
        STRING* mode = NULL;
        PMC* meta = PMC_metadata(SELF);
        if (meta) {
            PMC **m;
#if 0
            PMC *key = pmc_new(INTERP, dynpmc_LuaString);
            VTABLE_set_string_native(INTERP, key, const_string(INTERP, "__mode"));
            m = lua_get(INTERP, PMC_struct_val(meta), key);
#else
            m = lua_getstr(INTERP, PMC_struct_val(meta), const_string(INTERP, "__mode"));
#endif
            if (m && *m)
                mode = PMC_str_val(*m);
        }
        if (PMC_struct_val(SELF))
            lua_mark_table(INTERP, PMC_struct_val(SELF), mode);
        if (meta)
            pobject_lives(INTERP, (PObj *)meta);
    }

/*

=item C<void destroy()>

Free hash structure.

=cut

*/
    void destroy() {
        if (PMC_struct_val(SELF)) {
            lua_destroy_table(INTERP, PMC_struct_val(SELF));
            PMC_struct_val(SELF) = NULL;
        }
    }

/*

=item C<STRING* name()>

Return the string "table".

=cut

*/
    STRING* name() {
        return const_string(INTERP, "table");
    }

/*

=item C<PMC* clone()>

PMCs are always handled by-reference in Parrot. So, copying register contents
only copies the reference to the PMC. For LuaString, LuaNumber, LuaBoolean,
this is not correct, as Lua has by-value semantics for these types. In order
to be able to handle register "move" instructions, this should be implemented
using clone(). However, LuaTable and LuaFunction do have by-reference
semantics. As you don't know the type during compile-time of an object, just
always use clone() to copy register contents. LuaTable and LuaFunction should
therefore only clone the reference to themselves, not make a deep copy.

=cut

*/
    PMC* clone() {
        return SELF;
    }

/*

=item C<STRING* get_string()>

=cut

*/
    STRING* get_string() {
        return Parrot_sprintf_c(INTERP, "table: %08X", SELF);
    }

/*

=item C<void set_pmc(PMC *other)>

=cut

*/
    void set_pmc(PMC *other) {
        PMC_struct_val(SELF) = PMC_struct_val(other);
        PMC_metadata(SELF) = PMC_metadata(other);
    }

/*

=item C<PMC* get_pmc_keyed (PMC* key)>

C<table> accessor.

=cut

*/
    PMC* get_pmc_keyed(PMC* key) {
        PMC* value = NULL;
        PMC** pvalue = lua_get(INTERP, PMC_struct_val(SELF), key);
        if (pvalue == NULL) {
            PMC* meth = find_meth(INTERP, SELF, "__index");
            if (meth != NULL) {
                if (dynpmc_LuaClosure == PMC_type(meth)
                 || dynpmc_LuaFunction == PMC_type(meth)) {
                    value = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                     SELF, key);
                }
                else {
                    return VTABLE_get_pmc_keyed(INTERP, meth, key);
                }
            }
        }
        else
            value = *pvalue;
        if (value == NULL) {
            return pmc_new(INTERP, dynpmc_LuaNil);
        }
        return value;
    }

/*

=item C<void set_pmc_keyed(PMC* key, PMC* value)>

C<table> mutator.

=cut

*/
    void set_pmc_keyed(PMC* key, PMC* value) {
        if (NULL == lua_get(INTERP, PMC_struct_val(SELF), key)) {
            PMC* meth = find_meth(INTERP, SELF, "__newindex");
            if (meth != NULL) {
                if (dynpmc_LuaClosure == PMC_type(meth)
                 || dynpmc_LuaFunction == PMC_type(meth)) {
                    Parrot_runops_fromc_args(INTERP, meth, "vPPP",
                                             SELF, key, value);
                }
                else {
                    VTABLE_set_pmc_keyed(INTERP, meth, key, value);
                }
                return;
            }
        }
        if (dynpmc_LuaNil == PMC_type(value)) {
            value = NULL;
        }
        else {
            value = VTABLE_clone(interp, value);
            key = VTABLE_clone(interp, key);
        }
        *lua_set(INTERP, PMC_struct_val(SELF), key) = value;
    }

/*

=item C<INTVAL elements()>

Returns the number of elements in the table.

=cut

*/
    INTVAL elements() {
        return numuse(PMC_struct_val(SELF));
    }

/*

=back

=head2 non-Vtable Methods

=over 4

=item C<INTVAL is_equal(PMC* value)>

The C<==> operation. Compares reference (not in depth).

=cut

*/
    INTVAL is_equal(PMC* value) {
MMD_LuaTable: {
            PMC* meth = find_meth(INTERP, SELF, "__eq");
            if (meth != NULL) {
                PMC* retval = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                       SELF, value);
                if (PMC_IS_NULL(retval)) {
                    return (INTVAL)0;
                }
                return VTABLE_get_bool(INTERP, retval);
            }
            if (SELF == value)
                return (INTVAL)1;
            else
                return (INTVAL)0;
        }
MMD_DEFAULT: {
            return (INTVAL)0;
        }
    }

/*

=item C<INTVAL cmp(PMC *value)>

=cut

*/
    INTVAL cmp(PMC* value) {
MMD_LuaTable: {
#if 0
            PMC* meth = find_meth(INTERP, SELF, "__cmp");
            if (meth != NULL) {
                PMC* retval = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                       SELF, value);
                if (retval != NULL) {
                    return (INTVAL)VTABLE_get_number(INTERP, retval);
                }
            }
#else
            PMC* _lt = find_meth(INTERP, SELF, "__lt");
            if (_lt != NULL) {
                PMC* retval = Parrot_runops_fromc_args(INTERP, _lt, "PPP",
                                                       SELF, value);
                INTVAL r = (retval != NULL) ? VTABLE_get_bool(INTERP, retval)
                                            : (INTVAL)0;
                if (r) {
                    return (INTVAL)-1;
                }
                else {
                    PMC* _le = find_meth(INTERP, SELF, "__le");
                    if (_le != NULL) {
                        retval = Parrot_runops_fromc_args(INTERP, _le, "PPP",
                                                          SELF, value);
                        r = (retval != NULL) ? VTABLE_get_bool(INTERP, retval)
                                             : (INTVAL)0;
                        if (r) {
                            return (INTVAL)0;
                        }
                        else {
                            return (INTVAL)1;
                        }
                    }
                    else {
                        retval = Parrot_runops_fromc_args(INTERP, _lt, "PPP",
                                                          value, SELF);
                        r = (retval != NULL) ? VTABLE_get_bool(INTERP, retval)
                                             : (INTVAL)0;
                        if (r) {
                            return (INTVAL)1;
                        }
                        else {
                            return (INTVAL)0;
                        }
                    }
                }
            }
#endif
            real_exception(INTERP, NULL, ILL_INHERIT,
                    "attempt to compare two table values");
            return (INTVAL)0;
        }
MMD_DEFAULT: {
            real_exception(INTERP, NULL, ILL_INHERIT,
                    "attempt to compare table with %s",
                    string_to_cstring(INTERP, VTABLE_name(INTERP, value)));
            return (INTVAL)0;
        }
    }

/*

=back

=head2 Specific Methods

=over 4

=item C<PMC *get_metatable()>

=cut

*/
    METHOD PMC* get_metatable() {
        PMC* retval = PMC_metadata(SELF);
        if (NULL == retval)
            retval = pmc_new(INTERP, dynpmc_LuaNil);
        return retval;
    }

/*

=item C<PMC* len()>

=cut

*/
    METHOD PMC* len() {
        PMC** pvalue;
        PMC* key = pmc_new(INTERP, dynpmc_LuaNumber);
        INTVAL idx = 1;
        VTABLE_set_integer_native(INTERP, key, idx);
        pvalue = lua_get(INTERP, PMC_struct_val(SELF), key);
        while (pvalue && *pvalue) {
            idx ++;
            VTABLE_set_integer_native(INTERP, key, idx);
            pvalue = lua_get(INTERP, PMC_struct_val(SELF), key);
        }
        VTABLE_set_integer_native(INTERP, key, idx - 1);
        return key;
    }

/*

=item C<PMC* next(PMC* index)>

=cut

*/
    METHOD PMC* next(PMC* index) {
        Node* n = lua_next(INTERP, PMC_struct_val(SELF), index);
        if (NULL == n) {
            return pmc_new(INTERP, dynpmc_LuaNil);
        }
        else {
            PMC *retval = pmc_new(INTERP, enum_class_Array);
            VTABLE_set_integer_native(INTERP, retval, 2);
            VTABLE_set_pmc_keyed_int(INTERP, retval, 0, n->key);
            VTABLE_set_pmc_keyed_int(INTERP, retval, 1, n->val);
            return retval;
        }
    }

/*

=item C<PMC* rawequal(PMC* value)>

=cut

*/
    METHOD PMC* rawequal(PMC* value) {
        PMC* retval = pmc_new(INTERP, dynpmc_LuaBoolean);
        PMC_int_val(retval) = (SELF == value) ? 1 : 0;
        return retval;
    }

/*

=item C<PMC* rawget(PMC* key)>

=cut

*/
    METHOD PMC* rawget(PMC* key) {
        PMC** pvalue = lua_get(INTERP, PMC_struct_val(SELF), key);
        if (NULL == pvalue || NULL == *pvalue)
            return pmc_new(INTERP, dynpmc_LuaNil);
        return *pvalue;
    }

/*

=item C<void rawset(PMC* key, PMC* value)>

=cut

*/
    METHOD void rawset(PMC* key, PMC* value) {
        if (dynpmc_LuaNil == PMC_type(value)) {
            value = NULL;
        }
        else {
            value = VTABLE_clone(interp, value);
            key = VTABLE_clone(interp, key);
        }
        *lua_set(INTERP, PMC_struct_val(SELF), key) = value;
    }

/*

=item C<void set_metatable(PMC *meta)>

=cut

*/
    METHOD void set_metatable(PMC *meta) {
        if (dynpmc_LuaNil == PMC_type(meta)) {
            PMC_metadata(SELF) = NULL;
        }
        else {
            PMC_metadata(SELF) = meta;
        }
    }

}
/*

=back

=head1 AUTHORS

Francois Perrad

Klaas-Jan Stol

=cut

*/

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */