/*
Copyright (C) 2005-2008, The Perl Foundation.
$Id: /mirror/trunk/languages/lua/src/pmc/luatable.pmc 34462 2008-12-27T17:23:27.572097Z fperrad  $

=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 PMC_hash(s) (LuaHash *)PMC_struct_val((s))

#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 LuaHash {
    Node *node;
    Node *firstfree;  /* this position is free; all positions after it are full */
    PMC *container;
    int   size;
} LuaHash;

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

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

static int lua_equalObj(PARROT_INTERP, const PMC *t1, const PMC *t2)
{
    if (!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 LuaHash *t, 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, VTABLE_get_string(interp, key));
    }
    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 LuaHash *t, STRING *key)
{
    unsigned long h = string_hash(interp, key);
    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);

    /* key not found */
    return NULL;
}

static PMC** lua_get(PARROT_INTERP, const LuaHash *t, PMC *key)
{
    Node *n = mainposition(interp, t, key);

    if (!n)
        return NULL;

    do {
        if (lua_equalObj(interp, key, n->key))
            return &n->val;
        n = n->next;
    } while (n);

    /* key not found */
    return NULL;
}

static Node* lua_next(PARROT_INTERP, const LuaHash *t, PMC *key)
{
    int i;

    /* first iteration */
    if (key == NULL || PMC_type(key) == dynpmc_LuaNil)
        i = 0;
    else {
        PMC **v = lua_get(interp, t, key);
        if (!v || ! *v)
            Parrot_ex_throw_from_c_args(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)
            return n;
    }

    /* no more elements */
    return NULL;
}

static void rehash(PARROT_INTERP, LuaHash *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, LuaHash *t, PMC *key)
{
    Node *mp = mainposition(interp, t, key);
    Node *n  = mp;
    if (!mp)
        Parrot_ex_throw_from_c_args(interp, NULL, 1, "table index is nil");

    /* check whether `key' is somewhere in the chain */
    do {
        /* that's all */
        if (lua_equalObj(interp, key, n->key))
            return &n->val;
        else
            n = n->next;
    } while (n);

    /* `key' not found; must insert it */
    /* main position is not free? */
    if (mp->key) {
        Node *othern;        /* main position of colliding node */

        /* get a free place */
        n = t->firstfree;

        /* is colliding node out of its main position? (can only happen 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 */

            /* redo the chain with `n' in place of `mp' */
            othern->next = n;

            /* copy colliding node into free pos. (mp->next also goes) */
            *n = *mp;

            /* now `mp' is free */
            mp->next = NULL;
        }
        /* colliding node is in its own main position */
        else {
            /* new node will go into free position */
            /* chain new position */
            n->next  = mp->next;
            mp->next = n;
            mp       = n;
        }
    }

    mp->key = key;

    /* correct `firstfree' */
    for (;;) {
        /* OK; table still has a free place */
        if (! t->firstfree->key)
            return &mp->val;
        else if (t->firstfree == t->node)
            break;  /* cannot decrement from here */
        else
            (t->firstfree)--;
    }

    /* no more free places */
    rehash(interp, t);

    /* `rehash' invalidates this insertion */
    return lua_set(interp, t, key);
}

static void setnodevector(PARROT_INTERP, LuaHash *t, int size)
{
    int i;

    if (size > MAX_INT)
        Parrot_ex_throw_from_c_args(interp, NULL, 1, "table overflow");

    t->node      = mem_allocate_n_zeroed_typed(size, Node);
    t->size      = size;

    /* first free position to be used */
    t->firstfree = &t->node[size-1];
}

static int numuse(const LuaHash *t)
{
    Node *v       = t->node;
    int   size    = t->size;
    int   realuse = 0;
    int   i;

    for (i = 0; i < size; i++) {
        if (v[i].val)
            realuse++;
    }

    return realuse;
}

static void rehash(PARROT_INTERP, LuaHash *t)
{
    int   oldsize = t->size;
    Node *nold    = t->node;
    int   nelems   = numuse(t);
    int   i;

    LUA_ASSERT(nelems<=oldsize, "wrong count");

    Parrot_block_GC_mark(interp);

    /* using more than 3/4? */
    if (nelems >= oldsize-oldsize/4)
        setnodevector(interp, t, oldsize*2);

    /* less than 1/4? */
    else if (nelems <= oldsize/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)
            *lua_set(interp, t, old->key) = old->val;
    }

    Parrot_unblock_GC_mark(interp);

    /* free old array */
    mem_sys_free(nold);
}

static void lua_new_table(PARROT_INTERP, PMC *container)
{
    LuaHash * const t         = mem_allocate_zeroed_typed(LuaHash);
    PMC_struct_val(container) = t;
    t->container              = container;

    setnodevector(interp, t, MINPOWER2);
}

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

static void lua_mark_table(PARROT_INTERP, LuaHash *t, STRING *mode)
{
    Node *v        = t->node;
    int   mark_key = 1;
    int   mark_val = 1;
    int   i;

    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) {
            if (mark_key)
                pobject_lives(interp, (PObj *)v[i].key);
            if (mark_val)
                pobject_lives(interp, (PObj *)v[i].val);
        }
    }
}


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

/*

=item C<void init()>

Initializes the instance.

=cut

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

*/
    VTABLE 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_hash(meta), key);
#else
            m = lua_getstr(INTERP, PMC_hash(meta),
                    const_string(INTERP, "__mode"));
#endif
            if (m && *m)
                mode = PMC_str_val(*m);
        }

        if (PMC_struct_val(SELF))
            lua_mark_table(INTERP, PMC_hash(SELF), mode);

        if (meta)
            pobject_lives(INTERP, (PObj *)meta);
    }

/*

=item C<void destroy()>

Free hash structure.

=cut

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

/*

=item C<STRING* name()>

Return the string "table".

=cut

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

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

/*

=item C<STRING* get_string()>

=cut

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

/*

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

=cut

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

*/
    VTABLE PMC* get_pmc_keyed(PMC *key) {
        PMC  *value  = NULL;
        PMC **pvalue = lua_get(INTERP, PMC_hash(SELF), key);

        if (pvalue)
            value = *pvalue;
        else {
            PMC *meth = find_meth(INTERP, SELF, "__index");
            if (meth) {
                if (dynpmc_LuaFunction == PMC_type(meth)) {
                    value = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                 SELF, key);
                }
                else
                    return VTABLE_get_pmc_keyed(INTERP, meth, key);
            }
        }

        if (value)
            return value;

        return pmc_new(INTERP, dynpmc_LuaNil);
    }

/*

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

C<table> mutator.

=cut

*/
    VTABLE void set_pmc_keyed(PMC *key, PMC *value) {
        if (! lua_get(INTERP, PMC_hash(SELF), key)) {
            PMC *meth = find_meth(INTERP, SELF, "__newindex");
            if (meth) {
                if (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_hash(SELF), key) = value;
    }

/*

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

Need by NameSpace.export_to().

=cut

*/
    VTABLE void set_pmc_keyed_str(STRING *key, PMC *value) {
        PMC * pmc_key = pmc_new(INTERP, dynpmc_LuaString);
        VTABLE_set_string_native(INTERP, pmc_key, string_copy(INTERP, key));
        value = VTABLE_clone(interp, value);
        *lua_set(INTERP, PMC_hash(SELF), pmc_key) = value;
    }

/*

=item C<INTVAL elements()>

Returns the number of elements in the table.

=cut

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

/*

=back

=head2 non-Vtable Methods

=over 4

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

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

=cut

*/
    MULTI INTVAL is_equal(LuaTable value) {
        PMC *meth = find_meth(INTERP, SELF, "__eq");
        if (meth) {
            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;
    }

    MULTI INTVAL is_equal(DEFAULT value) {
        return (INTVAL)0;
    }

/*

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

=cut

*/
    MULTI INTVAL cmp(LuaTable value) {
#if 0
        PMC *meth = find_meth(INTERP, SELF, "__cmp");
        if (meth) {
            PMC *retval = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                   SELF, value);

            if (retval)
                return (INTVAL)VTABLE_get_number(INTERP, retval);
        }
#else
        PMC *_lt = find_meth(INTERP, SELF, "__lt");

        if (_lt) {
            PMC *retval = Parrot_runops_fromc_args(INTERP, _lt, "PPP",
                                                   SELF, value);
            INTVAL r = retval ? VTABLE_get_bool(INTERP, retval) : (INTVAL)0;

            if (r)
                return (INTVAL)-1;
            else {
                PMC *_le = find_meth(INTERP, SELF, "__le");
                if (_le) {
                    retval = Parrot_runops_fromc_args(INTERP, _le, "PPP",
                                                      SELF, value);
                    r = retval ?
                        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
                        ? VTABLE_get_bool(INTERP, retval) : (INTVAL)0;

                    if (r)
                        return (INTVAL)1;
                    else
                        return (INTVAL)0;
                }
            }
        }
#endif
        Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT,
                "attempt to compare two table values");
    }

    MULTI INTVAL cmp(DEFAULT value) {
        Parrot_ex_throw_from_c_args(INTERP, NULL, EXCEPTION_ILL_INHERIT,
            "attempt to compare table with %Ss",
                VTABLE_name(INTERP, value));
    }

/*

=back

=head2 Specific Methods

=over 4

=item C<PMC *get_metatable()>

=cut

*/
    METHOD PMC* get_metatable() {
        PMC *retval = PMC_metadata(SELF);

        if (!retval)
            retval = pmc_new(INTERP, dynpmc_LuaNil);

        RETURN(PMC *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_hash(SELF), key);

        while (pvalue && *pvalue) {
            idx++;
            VTABLE_set_integer_native(INTERP, key, idx);
            pvalue = lua_get(INTERP, PMC_hash(SELF), key);
        }

        VTABLE_set_integer_native(INTERP, key, idx - 1);
        RETURN(PMC *key);
    }

/*

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

=cut

*/
    METHOD PMC* next(PMC* index) {
        Node *n = lua_next(INTERP, PMC_hash(SELF), index);

        if (n) {
            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(PMC *retval);
        }
        else {
            PMC *retval = pmc_new(INTERP, dynpmc_LuaNil);
            RETURN(PMC *retval);
        }

    }

/*

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

=cut

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

/*

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

=cut

*/
    METHOD PMC* rawget(PMC *key) {
        PMC **pvalue = lua_get(INTERP, PMC_hash(SELF), key);
        PMC *retval;

        if (! pvalue || ! *pvalue)
            retval = pmc_new(INTERP, dynpmc_LuaNil);
        else
            retval = *pvalue;

        RETURN(PMC *retval);
    }

/*

=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_hash(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

=cut

*/

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