luatable.pmc

/*
Copyright (C) 2005-2009, Parrot Foundation.
$Id$

=head1 Lua Table

=head2 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.

=head3 Overloaded Methods

=over 4

=cut

*/

#include "lua_private.h"

#define t_mt(pmc)  (PARROT_LUATABLE(pmc))->mt

PMC *
_LuaTable_get_metatable(PARROT_INTERP, PMC *obj) {
    return t_mt(obj);
}

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

#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;

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

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

static int lua_equalObj(PARROT_INTERP, PMC * const t1, PMC * const t2)
{
    if (!t2)
        return 0;

    if (PMC_type(t1) != PMC_type(t2))
        return 0;

    if (PMC_type(t1) == dynpmc_LuaNumber)
        return VTABLE_get_number(interp, t1) == VTABLE_get_number(interp, t2);

    if (PMC_type(t1) == dynpmc_LuaBoolean)
        return VTABLE_get_integer(interp, t1) == VTABLE_get_integer(interp, t2);

    if (PMC_type(t1) == dynpmc_LuaString)
        return 0 == Parrot_str_compare(interp, VTABLE_get_string(interp, t1),
                                               VTABLE_get_string(interp, t2));

    return PMC_data(t1) == PMC_data(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 Parrot_LuaTable_attributes *t, PMC *key)
{
    unsigned long h;

    if (PMC_type(key) == dynpmc_LuaNil)
        return NULL;

    if (PMC_type(key) == dynpmc_LuaNumber) {
        h = (unsigned long)(long)VTABLE_get_number(interp, key);
    }
    else if (PMC_type(key) == dynpmc_LuaBoolean) {
        h = VTABLE_get_integer(interp, key);
    }
    else if (PMC_type(key) == dynpmc_LuaString) {
        h = Parrot_str_to_hashval(interp, VTABLE_get_string(interp, key));
    }
    else {
        h = (unsigned long)PMC_data(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 Parrot_LuaTable_attributes *t, STRING *key)
{
    unsigned long h = Parrot_str_to_hashval(interp, key);
    Node         *n = &t->node[h&(t->size-1)];

    do {
        if (PMC_type(n->key) == dynpmc_LuaString
         && 0 == Parrot_str_compare(interp, VTABLE_get_string(interp, n->key), key))
            return &n->val;

        n = n->next;
    } while (n);

    /* key not found */
    return NULL;
}

static PMC** lua_get(PARROT_INTERP, const Parrot_LuaTable_attributes *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 Parrot_LuaTable_attributes *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, Parrot_LuaTable_attributes *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, Parrot_LuaTable_attributes *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, Parrot_LuaTable_attributes *t, int size)
{
    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 Parrot_LuaTable_attributes *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, Parrot_LuaTable_attributes *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, Parrot_LuaTable_attributes *t)
{
    setnodevector(interp, t, MINPOWER2);
}

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

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

    if (mode) {
        mark_key = Parrot_str_find_index(interp, mode,
                    Parrot_str_new_constant(interp, "k"), 0) < 0;

        mark_val = Parrot_str_find_index(interp, mode,
                    Parrot_str_new_constant(interp, "v"), 0) < 0;
    }

    for (i = 0; i < t->size; i++) {
        if (v[i].val) {
            if (mark_key)
                Parrot_gc_mark_PMC_alive(interp, v[i].key);
            if (mark_val)
                Parrot_gc_mark_PMC_alive(interp, v[i].val);
        }
    }
}


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

    ATTR struct Node *node;
    ATTR struct Node *firstfree;  /* this position is free; all positions after it are full */
    ATTR INTVAL  size;
    ATTR PMC     *mt;

/*

=item C<void init()>

Initializes the instance.

=cut

*/
    VTABLE void init() {
        lua_new_table(INTERP, PARROT_LUATABLE(SELF));
        PObj_custom_mark_destroy_SETALL(SELF);
    }

/*

=item C<void mark()>

Marks the hash as live.

=cut

*/
    VTABLE void mark() {
        STRING *mode = NULL;
        PMC * const meta = t_mt(SELF);

        if (meta) {
            PMC **m;
#if 0
            PMC * const key = pmc_new(INTERP, dynpmc_LuaString);
            VTABLE_set_string_native(INTERP, key,
                    Parrot_str_new_constant(INTERP, "__mode"));
            m = lua_get(INTERP, PARROT_LUATABLE(meta), key);
#else
            m = lua_getstr(INTERP, PARROT_LUATABLE(meta),
                    Parrot_str_new_constant(INTERP, "__mode"));
#endif
            if (m && *m)
                mode = VTABLE_get_string(INTERP, *m);
        }

        lua_mark_table(INTERP, PARROT_LUATABLE(SELF), mode);

        if (meta)
            Parrot_gc_mark_PMC_alive(INTERP, meta);
    }

/*

=item C<void destroy()>

Free hash structure.

=cut

*/
    VTABLE void destroy() {
        lua_destroy_table(INTERP, PARROT_LUATABLE(SELF));
    }

/*

=item C<STRING* name()>

Return the string "table".

=cut

*/
    VTABLE STRING* name() {
        return Parrot_str_new_constant(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 assign_pmc(PMC *value)>

=cut

*/
    VTABLE void assign_pmc(PMC *value) {
        lua_destroy_table(INTERP, PARROT_LUATABLE(SELF));
        SUPER(value);
    }

/*

=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, PARROT_LUATABLE(SELF), key);

        if (pvalue)
            value = *pvalue;
        else {
            PMC * const meth = _LuaAny_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, PARROT_LUATABLE(SELF), key)) {
            PMC * const meth = _LuaAny_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, PARROT_LUATABLE(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 * const pmc_key = pmc_new(INTERP, dynpmc_LuaString);
        VTABLE_set_string_native(INTERP, pmc_key, Parrot_str_copy(INTERP, key));
        value = VTABLE_clone(INTERP, value);
        *lua_set(INTERP, PARROT_LUATABLE(SELF), pmc_key) = value;
    }

/*

=item C<INTVAL elements()>

Returns the number of elements in the table.

=cut

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

/*

=back

=head3 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 * const meth = _LuaAny_find_meth(INTERP, SELF, "__eq");
        if (meth) {
            PMC * const retval = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                          SELF, value);

            if (PMC_IS_NULL(retval))
                return (INTVAL)0;

            return VTABLE_get_bool(INTERP, retval);
        }

        return (SELF == value) ? (INTVAL)1 : (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 * const meth = _LuaAny_find_meth(INTERP, SELF, "__cmp");
        if (meth) {
            PMC * const retval = Parrot_runops_fromc_args(INTERP, meth, "PPP",
                                                          SELF, value);

            if (retval)
                return (INTVAL)VTABLE_get_number(INTERP, retval);
        }
#else
        PMC * const _lt = _LuaAny_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 * const _le = _LuaAny_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;

                    return (r) ? (INTVAL)0 : (INTVAL)1;
                }
                else {
                    retval = Parrot_runops_fromc_args(INTERP, _lt, "PPP",
                                                      value, SELF);
                    r = retval ? VTABLE_get_bool(INTERP, retval) : (INTVAL)0;

                    return (r) ? (INTVAL)1 : (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

=head3 Specific Methods

=over 4

=item C<PMC *get_metatable()>

=cut

*/
    METHOD PMC* get_metatable() {
        PMC *retval = _LuaTable_get_metatable(INTERP, SELF);

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

        RETURN(PMC *retval);
    }

/*

=item C<PMC* len()>

=cut

*/
    METHOD PMC* len() {
        PMC **pvalue;
        PMC * const key = pmc_new(INTERP, dynpmc_LuaNumber);
        INTVAL idx = 1;

        VTABLE_set_integer_native(INTERP, key, idx);

        pvalue = lua_get(INTERP, PARROT_LUATABLE(SELF), key);

        while (pvalue && *pvalue) {
            idx++;
            VTABLE_set_integer_native(INTERP, key, idx);
            pvalue = lua_get(INTERP, PARROT_LUATABLE(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 * const n = lua_next(INTERP, PARROT_LUATABLE(SELF), index);

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

    }

/*

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

=cut

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

/*

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

=cut

*/
    METHOD PMC* rawget(PMC *key) {
        PMC **pvalue = lua_get(INTERP, PARROT_LUATABLE(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, PARROT_LUATABLE(SELF), key) = value;
    }

/*

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

=cut

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

}
/*

=back

=cut

*/

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