array.c

/*---------------------------------------------------------------------------
 * Array handling functions.
 *
 *---------------------------------------------------------------------------
 * TODO: Rewrite the low-level functions (like allocate_array()) to return
 * TODO:: failure codes (errno like) instead of throwing errors. In addition,
 * TODO:: provide wrapper functions which do throw errorf()s, so that every
 * TODO:: caller can handle the errors himself (like the swapper).
 * The structure of an array ("vector") is defined in datatypes.h as this:
 *
 *   vector_t_s {
 *       p_int size;
 *       p_int ref;
 *       p_int extra_ref;          (ifdef DEBUG)
 *       wiz_list_t *user;
 *       svalue_t item[1...];
 *   };
 *
 * .size is the number of elements in the vector.
 *
 * .ref is the number of references to the vector. If this number
 * reaches 0, the vector can (and should) be deallocated. This scheme
 * breaks down with circular references, but those are caught by
 * the garbage collector.
 *
 * .extra_ref exists when the driver is compiled for DEBUGging, and
 * is used to countercheck the the .ref count.
 *
 * .user records which wizard's object created the vector, and is used
 * to keep the wizlist statistics (array usage) up to date.
 *
 * .item[] is the array of elements in indexing order. The structure
 * itself declares just an array of one element, it is task of the user
 * to allocated a big enough memory block.
 *
 *
 * Some macros help with the use of vector variables:
 *
 *   VEC_SIZE(v): Return the number of elements in v.
 *
 *   VEC_HEAD(size): Expand to the initializers of a vector with
 *       <size> elements and 1 ref. This does not include the
 *       element initialisers.
 *
 * This module contains both low-level and efun-level functions.
 * The latter are collected in the lower half of the source.
 *---------------------------------------------------------------------------
 */

#include "driver.h"
#include "typedefs.h"

#include "my-alloca.h"
#include <assert.h>
#include <stddef.h>

#include "array.h"
#include "backend.h"
#include "closure.h"    /* closure_cmp(), closure_eq() */
#include "interpret.h"
#include "main.h"
#include "mapping.h"
#include "mempools.h"
#include "mstrings.h"
#include "object.h"
#include "stdstrings.h"
#include "simulate.h"
#include "svalue.h"
#include "swap.h"
#include "wiz_list.h"
#include "xalloc.h"

#include "i-current_object.h"
#include "i-svalue_cmp.h"

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

#define ALLOC_VECTOR(nelem) \
      ((size_t)nelem > (SSIZE_MAX - sizeof(vector_t)) / sizeof(svalue_t)) \
      ? NULL \
      : (vector_t *)xalloc_pass(sizeof(vector_t) + \
                                sizeof(svalue_t) * (nelem))

/* ALLOC_VECTOR(size,file,line): Allocate dynamically the memory for
 *    a vector of <size> elements.
 * TODO: Use SIZET_MAX instead of SSIZE_MAX, see port.h
 */

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

int num_arrays;
  /* Total number of allocated arrays */

vector_t null_vector = { VEC_HEAD(0) };
  /* The global empty array ({}).
   * Reusing it is cheaper than repeated allocations/deallocations.
   */

void (*allocate_array_error_handler) (const char *, ...)
  = errorf; /* from simulate.c */
  /* This handler is called if an allocation fails.
   * Usually it points to simulate::errorf(), but the swapper
   * replaces it temporarily with its own dummy handler when
   * swapping in an object.
   */

/*-------------------------------------------------------------------------*/
vector_t *
_allocate_array(mp_int n MTRACE_DECL)

/* Allocate an array for <n> elements (but not more than the current
 * maximum) and return the pointer.
 * The elements are initialised to the svalue 0.
 *
 * If the allocations fails (and errorf() does return), a 0 pointer
 * may be returned. This is usually only possible when arrays
 * are allocated from the swapper.
 *
 * Allocating an array of size 0 will return a reference to the
 * globally shared empty array.
 *
 * If possible, annotate the allocations with <malloc_trace> and <...line>
 */

{
    mp_int i;
    vector_t *p;
    svalue_t *svp;

    if (n < 0 || (max_array_size && (size_t)n > max_array_size))
        errorf("Illegal array size: %"PRIdMPINT".\n", n);

    if (n == 0) {
        p = ref_array(&null_vector);
        return p;
    }

    num_arrays++;

    p = ALLOC_VECTOR(n);
    if (!p) {
#ifndef MALLOC_TRACE
        (*allocate_array_error_handler)
            ("Out of memory: array[%"PRIdMPINT"]\n", n);
#else
        (*allocate_array_error_handler)
            ("(%s:%d) Out of memory: array[%"PRIdMPINT"]\n"
             MTRACE_PASS, n);
#endif
        return 0;
    }

    p->ref = 1;
    p->size = n;
    p->user = get_current_user();
    if (!p->user)
        p->user = &default_wizlist_entry;
    p->user->size_array += n;

    svp = p->item;
    for (i = n; --i >= 0; )
        *svp++ = const0;

    return p;
}

/*-------------------------------------------------------------------------*/
vector_t *
_allocate_array_unlimited(mp_int n MTRACE_DECL)

/* Allocate an array for <n> elements and return the pointer.
 * The elements are initialised to the svalue 0.
 *
 * If the allocations fails (and errorf() does return), a 0 pointer
 * may be returned. This is usually only possible when arrays
 * are allocated from the swapper.
 *
 * Allocating an array of size 0 will return a reference to the
 * globally shared empty array.
 *
 * If possible, annotate the allocations with <malloc_trace_file> and <...line>
 */

{
    mp_int i;
    vector_t *p;
    svalue_t *svp;

    if (n < 0)
        errorf("Illegal array size: %"PRIdMPINT".\n", n);

    if (n == 0) {
        p = ref_array(&null_vector);
        return p;
    }

    num_arrays++;

    p = ALLOC_VECTOR(n);
    if (!p) {
#ifndef MALLOC_TRACE
        (*allocate_array_error_handler)
            ("Out of memory: unlimited array[%"PRIdMPINT"]\n", n);
#else
        (*allocate_array_error_handler)
            ("(%s:%d) Out of memory: unlimited array[%"PRIdMPINT"]\n"
            MTRACE_PASS, n);
#endif
        return 0;
    }

    p->ref = 1;
    p->size = n;
    p->user = get_current_user();
    if (!p->user)
        p->user = &default_wizlist_entry;
    p->user->size_array += n;

    svp = p->item;
    for (i = n; --i >= 0; )
        *svp++ = const0;

    return p;
}

/*-------------------------------------------------------------------------*/
vector_t *
_allocate_uninit_array (mp_int n MTRACE_DECL)

/* Allocate an array for <n> elements (but no more than the current
 * maximum) and return the pointer.
 * The elements are not initialised.
 * If the allocations fails (and errorf() does return), a 0 pointer
 * may be returned.
 *
 * Allocating an array of size 0 will return a reference to the
 * globally shared empty array.
 *
 * If possible, annotate the allocations with <malloc_trace_file> and <...line>
 */

{
    vector_t *p;

    if (n < 0 || (max_array_size && (size_t)n > max_array_size))
        errorf("Illegal array size: %"PRIdMPINT".\n", n);

    if (n == 0) {
        p = ref_array(&null_vector);
        return p;
    }

    num_arrays++;

    p = ALLOC_VECTOR(n);
    if (!p) {
#ifndef MALLOC_TRACE
        (*allocate_array_error_handler)
            ("Out of memory: uninited array[%"PRIdMPINT"]\n", n);
#else
        (*allocate_array_error_handler)
            ("(%s:%d) Out of memory: uninited array[%"PRIdMPINT"]\n"
            MTRACE_PASS, n);
#endif
        return 0;
    }

    p->ref = 1;
    p->size = n;
    p->user = get_current_user();
    if (!p->user)
        p->user = &default_wizlist_entry;
    p->user->size_array += n;

    return p;
}

/*-------------------------------------------------------------------------*/
void
_free_vector (vector_t *p)

/* Deallocate the vector <p>, properly freeing the contained elements.
 * The refcount is supposed to be zero at the time of call.
 */

{
    mp_uint i;
    svalue_t *svp;

#ifdef DEBUG
    if (p->ref > 0)
        fatal("Vector with %"PRIdPINT" refs passed to _free_vector()\n",
              p->ref);
    if (p == &null_vector)
        fatal("Tried to free the zero-size shared vector.\n");
#endif

    i = VEC_SIZE(p);

    num_arrays--;
    p->user->size_array -= i;

    svp = p->item;
    do {
        free_svalue(svp++);
    } while (--i);

    xfree(p);
} /* _free_vector() */

/*-------------------------------------------------------------------------*/
void
free_empty_vector (vector_t *p)

/* Deallocate the vector <p> without regard of refcount or contained
 * elements. Just the statistics are cared for.
 */

{
    mp_uint i;

    i = VEC_SIZE(p);
    p->user->size_array -= i;
    num_arrays--;
    xfree((char *)p);
}

/*-------------------------------------------------------------------------*/
void
check_for_destr (vector_t *v)

/* Check the vector <v> for destructed objects and closures on destructed
 * objects and replace them with svalue 0s. Subvectors are not checked,
 * though.
 *
 * This function is used by certain efuns (parse_command(), unique_array(),
 * map_array()) to make sure that the data passed to the efuns is valid,
 * avoiding game crashes (though this won't happen on simple operations
 * like assign_svalue).
 * TODO: The better way is to make the affected efuns resistant against
 * TODO:: destructed objects, and keeping this only as a safeguard and
 * TODO:: to save memory.
 */

{
    mp_int i;
    svalue_t *p;

    for (p = v->item, i = (mp_int)VEC_SIZE(v); --i >= 0 ; p++ )
    {
        if (destructed_object_ref(p))
            assign_svalue(p, &const0);
    }
} /* check_for_destr() */

/*-------------------------------------------------------------------------*/
long
total_array_size (void)

/* Statistics for the command 'status [tables]'.
 * Return the total memory used for all vectors in the game.
 */

{
    wiz_list_t *wl;
    long total;

    total = default_wizlist_entry.size_array;
    for (wl = all_wiz; wl; wl = wl->next)
        total += wl->size_array;
    total *= sizeof(svalue_t);
    total += num_arrays * sizeof(vector_t);
    return total;
}

/*-------------------------------------------------------------------------*/
#if defined(GC_SUPPORT)

void
clear_array_size (void)

/* Clear the statistics about the number and memory usage of all vectors
 * in the game.
 */

{
    wiz_list_t *wl;

    num_arrays = 0;
    default_wizlist_entry.size_array = 0;
    for (wl = all_wiz; wl; wl = wl->next)
        wl->size_array = 0;
} /* clear_array_size(void) */


/*-------------------------------------------------------------------------*/
void
count_array_size (vector_t *vec)

/* Add the vector <vec> to the statistics.
 */

{
    num_arrays++;
    vec->user->size_array += VEC_SIZE(vec);
} /* count_array_size(void) */

#endif /* GC_SUPPORT */

/*-------------------------------------------------------------------------*/
vector_t *
explode_string (string_t *str, string_t *del)

/* Explode the string <str> by delimiter string <del> and return an array
 * of the (unshared) strings found between the delimiters.
 * They are unshared because they are most likely short-lived.
 *
 * TODO: At some later point in the execution thread, all the longlived
 *   unshared strings should maybe be converted into shared strings.
 *
 * This is the new, logical behaviour: nothing is assumed.
 * The relation implode(explode(x,y),y) == x holds.
 *
 *   explode("xyz", "")         -> { "x", "y", "z" }
 *   explode("###", "##")       -> { "", "#" }
 *   explode(" the  fox ", " ") -> { "", "the", "", "", "fox", ""}
 *   explode("", whatever)      -> { "" }
 */

{
    char *p, *beg;
    long num;
    long len, left;
    vector_t *ret;
    string_t *buff;
    const ph_int stringtype = (str->info.unicode == STRING_BYTES) ? T_BYTES : T_STRING;

    /* Special case: str is an empty string. */
    if (mstrsize(str) == 0)
    {
        ret = allocate_array(1);
        ret->item->u.str = new_n_mstring("", 0, str->info.unicode);
        ret->item->type = stringtype;
        return ret;
    }
    
    len = (long)mstrsize(del);

    /* Delimiter is empty: return an array which holds all characters as
     *   single-character strings.
     */
    if (len < 1)
    {
        svalue_t *svp;

        if (str->info.unicode == STRING_UTF8)
        {
            size_t size = mstrsize(str);
            bool error = false;

            len = byte_to_char_index(get_txt(str), size, &error);
            if (error)
                errorf("Invalid character in string at byte %ld.\n", len);

            ret = allocate_array(len);
            for (svp = ret->item, p = get_txt(str); size > 0; svp++)
            {
                size_t chlen = char_to_byte_index(p, size, 1, &error);
                if (!chlen)
                    chlen = 1;

                buff = new_n_mstring(p, chlen, chlen == 1 ? STRING_ASCII : STRING_UTF8);
                if (!buff)
                {
                    free_array(ret);
                    outofmem(1, "explode() on a string");
                }
                put_string(svp, buff);

                p += chlen;
                size -= chlen;
            }
        }
        else
        {
            len = (long)mstrsize(str);
            ret = allocate_array(len);
            for ( svp = ret->item, p = get_txt(str)
                ; --len >= 0
                ; svp++, p++ )
            {
                buff = new_n_mstring(p, 1, str->info.unicode);
                if (!buff)
                {
                    free_array(ret);
                    outofmem(1, "explode() on a string");
                }
                svp->u.str = buff;
                svp->type = stringtype;
            }
        }

        return ret;
    }

    if (len <= 1)
    {
        /* Delimiter is one-char string: speedy implementation which uses
         *   direct character comparisons instead of calls to memcmp().
         */
        char c;
        char * txt;
        svalue_t *svp;

        txt = get_txt(str);
        len = (long)mstrsize(str);
        c = get_txt(del)[0];

        /* TODO: Remember positions here */
        /* Determine the number of delimiters in the string. */
        for (num = 1, p = txt
            ; p < txt + len && NULL != (p = memchr(p, c, len - (p - txt)))
            ; p++, num++) NOOP;

        ret = allocate_array(num);
        for ( svp = ret->item, left = len
            ; NULL != (p = memchr(txt, c, left))
            ; left -= (p + 1 - txt), txt = p + 1, svp++)
        {
            len = p - txt;
            buff = new_n_mstring(txt, (size_t)len, str->info.unicode);
            if (!buff)
            {
                free_array(ret);
                outofmem(len, "explode() on a string");
            }
            svp->u.str = buff;
            svp->type = stringtype;
        }

        /* txt now points to the (possibly empty) remains after
         * the last delimiter.
         */
        len = get_txt(str) + mstrsize(str) - txt;
        buff = new_n_mstring(txt, (size_t)len, str->info.unicode);
        if (!buff)
        {
            free_array(ret);
            outofmem(len, "explode() on a string");
        }
        if (buff->info.unicode == STRING_UTF8 && is_ascii(txt, len))
            buff->info.unicode = STRING_ASCII;

        svp->u.str = buff;
        svp->type = stringtype;

        return ret;
    }

    /* Find the number of occurrences of the delimiter 'del' by doing
     * a first scan of the string.
     *
     * The number of array items is then one more than the number of
     * delimiters, hence the 'num=1'.
     * TODO: Implement a strncmp() which returns the number of matching
     *   characters in case of a mismatch.
     * TODO: Remember the found positions so that we don't have to
     *   do the comparisons again.
     */
    for (p = get_txt(str), left = mstrsize(str), num=1 ; left > 0; )
    {
        if (left >= len && memcmp(p, get_txt(del), (size_t)len) == 0) {
            p += len;
            left -= len;
            num++;
        }
        else
        {
            p += 1;
            left -= 1;
        }
    }

    ret = allocate_array(num);

    /* Extract the <num> strings into the result array <ret>.
     *   <buff> serves as temporary buffer for the copying.
     */
    for (p = get_txt(str), beg = get_txt(str), num = 0, left = mstrsize(str)
        ; left > 0; )
    {
        if (left >= len && memcmp(p, get_txt(del), (size_t)len) == 0)
        {
            ptrdiff_t bufflen;

            bufflen = p - beg;
            buff = new_n_mstring(beg, (size_t)bufflen, str->info.unicode);
            if (!buff)
            {
                free_array(ret);
                outofmem(bufflen, "buffer for explode()");
            }

            if (buff->info.unicode == STRING_UTF8 && is_ascii(beg, (size_t)bufflen))
                buff->info.unicode = STRING_ASCII;

            ret->item[num].u.str = buff;
            ret->item[num].type = stringtype;

            num++;
            beg = p + len;
            p = beg;
            left -= len;

        } else {
            p += 1;
            left -= 1;
        }
    }

    /* Copy the last occurence (may be empty). */
    len = get_txt(str) + mstrsize(str) - beg;
    buff = new_n_mstring(beg, (size_t)len, str->info.unicode);
    if (!buff)
    {
        free_array(ret);
        outofmem(len, "last fragment in explode()");
    }
    if (buff->info.unicode == STRING_UTF8 && is_ascii(beg, (size_t)len))
        buff->info.unicode = STRING_ASCII;
    ret->item[num].u.str = buff;
    ret->item[num].type = stringtype;

    return ret;
} /* explode_string() */

/*-------------------------------------------------------------------------*/
string_t *
arr_implode_string (vector_t *arr, string_t *del MTRACE_DECL)

/* Implode the string vector <arr> by <del>, i.e. all strings from <arr>
 * with <del> interspersed are concatenated into one string. The
 * resulting string is returned. The function will return at least
 * the empty string "".
 *
 * Non-string elements are ignored; elements referencing destructed
 * objects are replaced by the svalue number 0.
 *
 *   implode({"The", "fox", ""}, " ") -> "The fox "
 *
 * If possible, annotate the allocations with <file> and <line>
 */

{
    mp_int size, i, arr_size;
    size_t del_len;
    char *deltxt;
    char *p;
    string_t *result;
    svalue_t *svp;
    bool first = true;
    ph_int stringtype = (del->info.unicode == STRING_BYTES) ? T_BYTES : T_STRING;
    bool isutf8 = false;

    del_len = mstrsize(del);
    deltxt = get_txt(del);

    /* Compute the <size> of the final string
     */
    size = -(mp_int)del_len;
    for (i = (arr_size = (mp_int)VEC_SIZE(arr)), svp = arr->item; --i >= 0; svp++)
    {
        svalue_t *elem = get_rvalue(svp, NULL);
        if (elem == NULL)
        {
            /* This is a range. */
            assert(svp->type == T_LVALUE);
            if (svp->x.lvalue_type == LVALUE_PROTECTED_RANGE)
            {
                struct protected_range_lvalue *r = svp->u.protected_range_lvalue;
                if (r->vec.type == stringtype)
                    size += (mp_int)del_len + r->index2 - r->index1;
            }
        }
        else if (elem->type == stringtype)
            size += (mp_int)del_len + mstrsize(elem->u.str);
    }

    /* Allocate the string; cop out if there's nothing to implode.
     */
    if (size <= 0)
        return ref_mstring(stringtype == T_STRING ? STR_EMPTY : empty_byte_string);

    result = mstring_alloc_string(size MTRACE_PASS);
    if (!result)
    {
        /* caller raises the errorf() */
        return NULL;
    }
    p = get_txt(result);

    /* Concatenate the result string.
     *
     * <i>   is the number of elements left to check,
     * <svp> is the next element to check,
     * <p>   points to the current end of the result string.
     */

    svp = arr->item;
    i = arr_size;

    while (i-- > 0)
    {
        svalue_t *elem = get_rvalue(svp, NULL);
        if (elem == NULL)
        {
            /* This is a range. */
            assert(svp->type == T_LVALUE);
            if (svp->x.lvalue_type == LVALUE_PROTECTED_RANGE)
            {
                struct protected_range_lvalue *r = svp->u.protected_range_lvalue;
                if (r->vec.type == stringtype)
                {
                    if (first)
                        first = false;
                    else
                    {
                        memcpy(p, deltxt, del_len);
                        p += del_len;
                    }

                    memcpy(p, get_txt(r->vec.u.str) + r->index1, r->index2 - r->index1);
                    if (!isutf8 && stringtype == T_STRING && r->vec.u.str->info.unicode == STRING_UTF8 && !is_ascii(p, r->index2 - r->index1))
                        isutf8 = true;

                    p += r->index2 - r->index1;
                }
            }
        }
        else if (elem->type == stringtype)
        {
            if (first)
                first = false;
            else
            {
                memcpy(p, deltxt, del_len);
                p += del_len;
            }
            memcpy(p, get_txt(elem->u.str), mstrsize(elem->u.str));
            p += mstrsize(elem->u.str);
            if (elem->u.str->info.unicode == STRING_UTF8)
                isutf8 = true;
        }

        svp++;
    }

    result->info.unicode = (stringtype == T_BYTES) ? STRING_BYTES : isutf8 ? STRING_UTF8 : STRING_ASCII;

    assert(p - get_txt(result) == size);
    return result;
} /* implode_array() */

/*-------------------------------------------------------------------------*/
vector_t *
slice_array (vector_t *p, mp_int from, mp_int to)

/* Create a vector slice from vector <p>, range <from> to <to> inclusive,
 * and return it.
 *
 * <to> is guaranteed to not exceed the size of <p>.
 * If <from> is greater than <to>, the empty array is returned.
 */

{
    vector_t *d;
    int cnt;

    if (from < 0)
        from = 0;

    if (to < from)
        return allocate_array(0);

    d = allocate_array(to-from+1);
    for (cnt = from; cnt <= to; cnt++)
        assign_rvalue_no_free(&d->item[cnt-from], &p->item[cnt]);

    return d;
}

/*-------------------------------------------------------------------------*/
vector_t *
add_array (vector_t *p, vector_t *q)

/* Concatenate the vectors <p> and <q> and return the resulting vector.
 * <p> and <q> are not modified.
 */

{
    mp_int cnt;
    svalue_t *s, *d;
    mp_int q_size;

    s = p->item;
    p = allocate_array((cnt = (mp_int)VEC_SIZE(p)) + (q_size = (mp_int)VEC_SIZE(q)));
    d = p->item;
    for ( ; --cnt >= 0; ) {
        assign_svalue_no_free (d++, s++);
    }
    s = q->item;
    for (cnt = q_size; --cnt >= 0; ) {
        assign_svalue_no_free (d++, s++);
    }
    return p;
} /* add_array() */

/*-------------------------------------------------------------------------*/
static INLINE void
sanitize_array (vector_t * vec)

/* In the given array, make all strings tabled, and replace destructed
 * object references by svalue 0s.
 * Used for example in preparation for ordering the array.
 */

{
    size_t     j, keynum;
    svalue_t * inpnt;

    keynum = VEC_SIZE(vec);
    for ( j = 0, inpnt = vec->item; j < keynum; j++, inpnt++)
    {
        if (inpnt->type == T_STRING || inpnt->type == T_BYTES)
        {
            if (!mstr_tabled(inpnt->u.str))
            {
                inpnt->u.str = make_tabled(inpnt->u.str);
            }
        }
        else if (destructed_object_ref(inpnt))
        {
            free_svalue(inpnt);
            put_number(inpnt, 0);
        }
    }
} /* sanitize_array() */

/*-------------------------------------------------------------------------*/
ptrdiff_t *
get_array_order (vector_t * vec )

/* Determine the order of the elements in vector <vec> and return the
 * sorted indices (actually svalue_t* pointer diffs). The order is
 * determined by rvalue_cmp() (which happens to be high-to-low).
 *
 * As a side effect, strings in the vector are made shared, and
 * destructed objects in the vector are replaced by svalue 0s.
 */

{
    ptrdiff_t * sorted;
      /* The vector elements in sorted order, given as the offsets of the array
       * element in question to the start of the vector. This way,
       * sorted[] needs only to be <keynum> elements long.
       * sorted[] is created from root[] after sorting.
       */

    svalue_t **root;
      /* Auxiliary array with the sorted keys as svalue* into vec.
       * This way the sorting is given by the order of the pointers, while
       * the original position is given by (pointer - vec->item).
       * The very first element is a dummy (heapsort uses array indexing
       * starting with index 1), the next <keynum> elements are scratch
       * area, the final <keynum> elements hold the sorted keys in reverse
       * order.
       */
    svalue_t **root2;   /* Aux pointer into *root. */
    svalue_t *inpnt;    /* Pointer to the value to copy into the result */
    mp_int keynum;      /* Number of keys */
    int j;

    keynum = (mp_int)VEC_SIZE(vec);

    xallocate(sorted, keynum * sizeof(ptrdiff_t) + sizeof(ptrdiff_t)
             , "sorted index array");
      /* The extra sizeof(ptrdiff_t) is just to have something in
       * case keynum is 0.
       */

    sanitize_array(vec);

    /* For small arrays, use something else but Heapsort - trading
     * less overhead for worse complexity.
     * TODO: The limit of '6' is arbitrary (it was the transition point
     * TODO:: on my machine) - a better way would be to test the system
     * TODO:: speed at startup.
     */
    if (keynum <= 6)
    {
        switch (keynum)
        {
        case 0:
            /* Do nothing */
            break;

        case 1:
            sorted[0] = 0;
            break;

        case 2:
            if (rvalue_cmp(vec->item, vec->item + 1) > 0)
            {
                sorted[0] = 0;
                sorted[1] = 1;
            }
            else
            {
                sorted[0] = 1;
                sorted[1] = 0;
            }
            break;

        case 3:
          {
            int d;

            sorted[0] = 0;
            sorted[1] = 1;
            sorted[2] = 2;
            d = rvalue_cmp(vec->item, vec->item + 1);
            if (d < 0)
            {
                sorted[1] = 0;
                sorted[0] = 1;
            }
            d = rvalue_cmp(vec->item + sorted[0], vec->item + 2);
            if (d < 0)
            {
                ptrdiff_t tmp = sorted[2];
                sorted[2] = sorted[0];
                sorted[0] = tmp;
            }
            d = rvalue_cmp(vec->item + sorted[1], vec->item + sorted[2]);
            if (d < 0)
            {
                ptrdiff_t tmp = sorted[2];
                sorted[2] = sorted[1];
                sorted[1] = tmp;
            }
            break;
          } /* case 3 */

        default:
          {
            size_t  start;  /* Index of the next position to set */

            /* Initialise the sorted[] array */
            for (start = 0; (mp_int)start < keynum; start++)
                sorted[start] = (ptrdiff_t)start;

            /* Outer loop: walk start through the array, being the position
             * where the next highest element has to go.
             */
            for (start = 0; (mp_int)start < keynum-1; start++)
            {
                size_t    max_idx;  /* Index (in sorted[]) of the current max */
                svalue_t *max;      /* Pointer to the current max svalue */
                size_t    test_idx; /* Index of element to test */

                /* Find the highest element in the remaining vector */
                max_idx = start;
                max = vec->item + sorted[start];

                for (test_idx = start+1; (mp_int)test_idx < keynum; test_idx++)
                {
                    svalue_t *test = vec->item + sorted[test_idx];

                    if (rvalue_cmp(max, test) < 0)
                    {
                        max_idx = test_idx;
                        max = test;
                    }
                }

                /* Put the found maximum at position start */
                if (max_idx != start)
                {
                    ptrdiff_t tmp = sorted[max_idx];
                    sorted[max_idx] = sorted[start];
                    sorted[start] = tmp;
                }
            }
            break;
          } /* case default */
        } /* switch(keynum) */

        return sorted;
    }

    /* Allocate the auxiliary array. */
    root = (svalue_t **)alloca(keynum * sizeof(svalue_t *[2])
                                           + sizeof(svalue_t)
                              );
    if (!root)
    {
        errorf("Stack overflow in get_array_order()");
        /* NOTREACHED */
        return NULL;
    }

    /* Heapsort vec into *root.
     */

    /* Heapify the keys into the first half of root */
    for ( j = 1, inpnt = vec->item
        ; j <= keynum
        ; j++, inpnt++)
    {
        int curix, parix;

        /* propagate the new element up in the heap as much as necessary */
        for (curix = j; 0 != (parix = curix>>1); ) {
            if ( rvalue_cmp(root[parix], inpnt) > 0 ) {
                root[curix] = root[parix];
                curix = parix;
            } else {
                break;
            }
        }
        root[curix] = inpnt;
    }

    root++; /* Adjust root to ignore the heapsort-dummy element */

    /* Sort the heaped keys from the first into the second half of root. */
    root2 = &root[keynum];
    for(j = keynum; --j >= 0; ) {
        int curix;

        *root2++ = *root;
        for (curix=0; ; ) {
            int child, child2;

            child = curix+curix+1;
            child2 = child+1;
            if (child2 >= keynum) {
                if (child2 == keynum && root[child]) {
                    root[curix] = root[child];
                    curix = child;
                }
                break;
            }
            if (root[child2]) {
                if (!root[child] || rvalue_cmp(root[child], root[child2]) > 0)
                {
                    root[curix] = root[child2];
                    curix = child2;
                    continue;
                }
            } else if (!root[child]) {
                break;
            }
            root[curix] = root[child];
            curix = child;
        }
        root[curix] = 0;
    }

    /* Compute the sorted offsets from root[] into sorted[].
     * Note that root[] is in reverse order.
     */
    for (root = &root[keynum], j = 0; j < keynum; j++)
        sorted[j] = root[keynum-j-1] - vec->item;

    return sorted;
} /* get_array_order() */

/*-------------------------------------------------------------------------*/
vector_t *
order_array (vector_t *vec)

/* Order the array <vec> and return a new vector with the sorted data.
 * The sorting order is the internal order defined by rvalue_cmp() (which
 * happens to be high-to-low).
 *
 * This function and lookup_key() are used in several places for internal
 * lookup functions (e.g. in say()).
 *
 * As a side effect, strings in the vector are made shared, and
 * destructed objects in the vector are replaced by svalue 0s.
 */

{
    vector_t  * out;     /* The result vector of vectors */
    svalue_t  * outpnt;  /* Next result value element to fill in */
    ptrdiff_t * sorted;  /* The vector elements in sorted order */
    long        keynum;  /* Number of keys */
    long j;

    keynum = (long)VEC_SIZE(vec);

    sorted = get_array_order(vec);

    /* Copy the elements from the in-vector to the result vector.
     */
    out = allocate_array(VEC_SIZE(vec));
    outpnt = out->item;
    for (j = keynum; --j >= 0; )
    {
         assign_svalue_no_free(outpnt++, vec->item + sorted[j]);
    }

    xfree(sorted);

    return out;
} /* order_array() */

/*-------------------------------------------------------------------------*/
long
lookup_key (svalue_t *key, vector_t *vec)

/* Lookup up value <key> in ordered vector <vec> and return it's position.
 * If not found, return as negative number the position at which the
 * key would have to be inserted, incremented by 1. That is:
 *   -1          -> key should be at position 0,
 *   -2          -> key should be at position 1,
 *   -len(vec)-1 -> key should be appended to the vector.
 *
 * <vec> must be sorted according to rvalue_cmp(), else the result will be
 * interesting, but useless.
 *
 * The function is used by object.c and pkg-alists.c .
 */

{
    mp_int i, o, d, keynum;
    svalue_t shared_string_key;
      /* The svalue used to shared search key during the search.
       * It does not count as reference!
       */

    /* If key is a non-shared string, lookup and use the shared copy.
     */
    if ((key->type == T_STRING || key->type == T_BYTES) && !mstr_tabled(key->u.str))
    {
        shared_string_key.type = key->type;
        if ( !(shared_string_key.u.str = find_tabled(key->u.str)) )
        {
            return -1;
        }
        key = &shared_string_key;
    }

    if ( !(keynum = (mp_int)VEC_SIZE(vec)) )
        return -1;

    /* Simple binary search */

    i = keynum >> 1;
    o = (i+2) >> 1;
    for (;;) {
        d = rvalue_cmp(key, &vec->item[i]);
        if (d < 0)
        {
            i -= o;
            if (i < 0)
            {
                i = 0;
            }
        }
        else if (d > 0)
        {
            i += o;
            if (i >= keynum)
            {
                i = keynum-1;
            }
        }
        else
        {
            /* Found! */
            return i;
        }

        if (o <= 1)
        {
            /* Last element to try */
            d = rvalue_cmp(key, &vec->item[i]);
            if (d == 0) return i;
            if (d > 0) return -(i+1)-1;
            return -i-1;
        }
        o = (o+1) >> 1;
    }

    /* NOTREACHED */
    return -1;
} /* lookup_key() */

/*-------------------------------------------------------------------------*/
static Bool *
match_arrays (vector_t *vec1, vector_t *vec2)

/* Compare the contents of the two (unordered) vectors <vec1> and
 * <vec2> and return a boolean vector describing for each vector
 * which elements are in both.
 *
 * The resulting bool vector has len(vec1)+len(vec2) flags (but
 * at least 1); the first describing the elements of vec1, the last
 * describing those of vec2. Each flag is FALSE if the vector entry
 * is unique, and TRUE if the same value appears in the other vector.
 *
 * When out of memory, an errorf() is thrown.
 */

{
    size_t  len1, len2, len; /* Length of vec1, vec2, and both summed */
    Bool   *flags;           /* The resulting flag vector */

    len1 = VEC_SIZE(vec1);
    len2 = VEC_SIZE(vec2);

    /* Get the flag vector, default it to 'non matching'. */
    len = len1 + len2; if (!len) len = 1;
    xallocate(flags, len * sizeof(Bool), "flag vector");
    memset(flags, 0, len * sizeof(Bool));

    /* Test some special cases */

    /* Special case: if one of the vectors is empty, no elements match */
    if (len1 == 0 || len2 == 0)
        return flags;

    /* Special case: if one of the vectors has only one element,
     * a simple linear comparison is sufficient.
     */
    if (len1 == 1 || len2 == 1)
    {
        svalue_t * rover;  /* Pointer to the long vector elements */
        size_t     rlen;   /* Length (remaining) in the long vector */
        svalue_t * elem;   /* Pointer to the single-elem vector elements */
        Bool     * rflag;  /* Pointer to the long vector flags */
        Bool     * eflag;  /* Pointer to the single-elem vector flag */

        sanitize_array(vec1);
        sanitize_array(vec2);

        /* Sort out which vector is which */
        if  (len1 == 1)
        {
            /* Even more special case: both vectors have just one elem */
            if (len2 == 1)
            {
                if (!rvalue_eq(vec1->item, vec2->item))
                {
                    flags[0] = flags[1] = MY_TRUE;
                }
                return flags;
            }

            /* vec1 is the short one */
            rover = vec2->item;
            rlen = len2;
            rflag = flags + len1;
            elem = vec1->item;
            eflag = flags;
        }
        else /* len2 == 1 */
        {
            /* vec2 is the short one */
            rover = vec1->item;
            rlen = len1;
            rflag = flags;
            elem = vec2->item;
            eflag = flags + len1;
        }

        /* Now loop over all elements in the long vector and compare
         * them to the one in the short vector.
         */
        for ( ; rlen != 0; rlen--, rover++, rflag++)
        {
            if (!rvalue_eq(rover, elem))
                *rflag = *eflag = MY_TRUE;
        }

        /* Done */
        return flags;
    } /* if (one vector has only one element */

    /* The generic matching routine: first both arrays are ordered,
     * then compared side by side.
     */
    {
        ptrdiff_t *sorted1, *sorted2; /* Ordered indices to the vectors */
        ptrdiff_t *index1, *index2;   /* Current elements to compare */
        Bool      *flag1, *flag2;     /* flags base pointers */

        sorted1 = get_array_order(vec1);
        sorted2 = get_array_order(vec2);

        /* Set up the comparison */
        index1 = sorted1;
        index2 = sorted2;
        flag1 = flags;
        flag2 = flags + len1;

        /* Compare side by side. Any element left uncompared at
         * the end is automatically non-matching.
         */
        while (len1 != 0 && len2 != 0)
        {
            int d;

            d = rvalue_cmp(vec1->item + *index1, vec2->item + *index2);
            if (d == 0)
            {
                /* Elements match */
                svalue_t *test_val = vec1->item+*index1;

                /* Important here is to remember that there might
                 * be several elements of the same value in a row.
                 * The side-by-side comparison itself is not able
                 * to handle it, so we have to check here manually
                 * for it.
                 * The loops will leave index1/index2 point to the
                 * first element after the sequence of matching ones.
                 */
                do {
                    flag1[*index1] = MY_TRUE;
                    index1++;
                    len1--;
                    if (len1 != 0)
                        d = rvalue_eq(test_val, vec1->item + *index1);
                }
                while (len1 != 0 && d == 0);

                do {
                    flag2[*index2] = MY_TRUE;
                    index2++;
                    len2--;
                    if (len2 != 0)
                        d = rvalue_eq(test_val, vec2->item + *index2);
                }
                while (len2 != 0 && d == 0);

                continue; /* Next iteration of the main loop */
            }

            /* Else advance in array(s) */
            if (d > 0)
            {
                index1++;
                len1--;
            }

            if (d < 0)
            {
                index2++;
                len2--;
            }
        } /* while (in both vectors) */

        /* Cleanup */
        xfree(sorted1);
        xfree(sorted2);

        /* Done */
        return flags;
    }

    /* NOTREACHED */
    return flags;

} /* match_array() */

/*-------------------------------------------------------------------------*/
vector_t *
subtract_array (vector_t *minuend, vector_t *subtrahend)

/* Subtract all elements in <subtrahend> from the vector <minuend>
 * and return the resulting difference vector.
 * <subtrahend> and <minuend> are freed.
 */

{
    Bool     *flags;       /* The result from match_arrays() */
    size_t    result_size; /* Size of the result array */
    vector_t *result;      /* Result array */
    svalue_t *dest;        /* Pointer for storing the result elements */
    size_t i;

    size_t minuend_size    = VEC_SIZE(minuend);
    size_t subtrahend_size = VEC_SIZE(subtrahend);

    /* Handle empty vectors quickly */

    if (minuend_size == 0 || subtrahend_size == 0)
    {
        free_array(subtrahend);
        return minuend;
    }

    /* Non-trivial arrays: match them up */
    flags = match_arrays(minuend, subtrahend);

    /* Count how many elements would be left in minuend
     * and allocate the result array.
     */
    for (i = result_size = 0; i < minuend_size; i++)
    {
        if (!flags[i])
            result_size++;
    }

    if (result_size == minuend_size)
    {
        /* No elements to remove */
        xfree(flags);
        free_array(subtrahend);
        return minuend;
    }

    if (max_array_size && result_size > max_array_size)
    {
        xfree(flags);
        free_array(minuend);
        free_array(subtrahend);
        errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
    }

    result = allocate_array(result_size);

    /* Copy the elements to keep from minuend into result.
     * We count down result_size to be able to stop as early
     * as possible.
     */
    for ( dest = result->item, i = 0
        ; i < minuend_size && result_size != 0
        ; i++
        )
    {
        if (!flags[i])
        {
            assign_rvalue_no_free(dest, minuend->item+i);
            dest++;
            result_size--;
        }
    }

    /* Cleanup and return */
    xfree(flags);
    free_array(minuend);
    free_array(subtrahend);

    return result;
} /* subtract_array() */

/*-------------------------------------------------------------------------*/
vector_t *
intersect_array (vector_t *vec1, vector_t *vec2)

/* OPERATOR & (array intersection)
 *
 * Perform an intersection of the two vectors <vec1> and <vec2>.
 * The result is a new vector with all elements which are present in both
 * input vectors.
 *
 * Both <vec1> and <vec2> are freed.
 */

{
    Bool     *flags;       /* The result from match_arrays() */
    size_t    result_size; /* Size of the result array */
    vector_t *result;      /* Result array */
    svalue_t *dest;        /* Pointer for storing the result elements */
    size_t i;

    size_t vec1_size = VEC_SIZE(vec1);
    size_t vec2_size = VEC_SIZE(vec2);

    /* Handle empty arrays quickly */

    if (vec1_size == 0 || vec2_size == 0)
    {
        free_array(vec2);
        free_array(vec1);
        return ref_array(&null_vector);
    }

    /* Non-trivial arrays: match them up */
    flags = match_arrays(vec1, vec2);

    /* Count how many elements have to be copied from vec1
     * and allocate the result array.
     */
    for (i = result_size = 0; i < vec1_size; i++)
    {
        if (flags[i])
            result_size++;
    }

    if (result_size == vec1_size)
    {
        /* No elements to remove */
        xfree(flags);
        free_array(vec2);
        return vec1;
    }

    if (max_array_size && result_size > max_array_size)
    {
        xfree(flags);
        free_array(vec1);
        free_array(vec2);
        errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
    }

    result = allocate_array(result_size);

    /* Copy the elements to keep from vec1 into result.
     * We count down result_size to be able to stop as early
     * as possible.
     */
    for ( dest = result->item, i = 0
        ; i < vec1_size && result_size != 0
        ; i++
        )
    {
        if (flags[i])
        {
            assign_svalue_no_free(dest, vec1->item+i);
            dest++;
            result_size--;
        }
    }

    /* Cleanup and return */
    xfree(flags);
    free_array(vec1);
    free_array(vec2);

    return result;
} /* intersect_array() */

/*-------------------------------------------------------------------------*/
vector_t *
join_array (vector_t *vec1, vector_t *vec2)

/* OPERATOR | (array union)
 *
 * Perform a join of the two vectors <vec1> and <vec2>.
 * The result is a new vector with all elements <vec1> and those elements
 * from <vec2> which are not present in <vec1>.
 *
 * Both <vec1> and <vec2> are freed.
 */

{
    Bool     *flags;       /* The result from match_arrays() */
    size_t    result_size; /* Size of the result array */
    vector_t *result;      /* Result array */
    svalue_t *src;         /* Pointer for getting the result elements */
    svalue_t *dest;        /* Pointer for storing the result elements */
    size_t i;

    size_t vec1_size = VEC_SIZE(vec1);
    size_t vec2_size = VEC_SIZE(vec2);
    size_t sum_size = vec1_size + vec2_size;

    /* Handle empty arrays quickly */

    if (vec1_size == 0)
    {
        free_array(vec1);
        return vec2;
    }

    if (vec2_size == 0)
    {
        free_array(vec2);
        return vec1;
    }

    /* Non-trivial arrays: match them up */
    flags = match_arrays(vec1, vec2);

    /* Count how many elements have to be copied from vec2
     * (we have to get all from vec1 anyway) and allocate the result array.
     */
    result_size = 0;
    for (i = vec1_size; i < sum_size; i++)
    {
        if (!flags[i])
            result_size++;
    }

    if (result_size == 0)
    {
        /* No elements to copy */
        xfree(flags);
        free_array(vec2);
        return vec1;
    }

    if (max_array_size && result_size+vec1_size > max_array_size)
    {
        xfree(flags);
        errorf("Illegal array size: %lu.\n", (unsigned long)(result_size+vec1_size));
    }

    result = allocate_array(vec1_size+result_size);

    /* Copy the elements to keep from vec1 into result.
     */
    for (dest = result->item, i = 0 ; i < vec1_size ; i++)
    {
        assign_svalue_no_free(dest, vec1->item+i);
        dest++;
    }

    /* Copy the elements to keep from vec1 into result.
     * We count down result_size to be able to stop as early
     * as possible.
     */
    for ( src = vec2->item, dest = result->item + vec1_size, i = vec1_size
        ; i < sum_size && result_size != 0
        ; i++, src++
        )
    {
        if (!flags[i])
        {
            assign_svalue_no_free(dest, src);
            dest++;
            result_size--;
        }
    }

    /* Cleanup and return */
    xfree(flags);
    free_array(vec1);
    free_array(vec2);

    return result;
} /* join_array() */

/*-------------------------------------------------------------------------*/
vector_t *
symmetric_diff_array (vector_t *vec1, vector_t *vec2)

/* OPERATOR ^ (symmetric array difference)
 *
 * Compute the symmetric difference of the two vectors <vec1> and <vec2>.
 * The result is a new vector with all elements which are present in only
 * one of the input vectors.
 *
 * Both <vec1> and <vec2> are freed.
 */

{
    Bool     *flags;       /* The result from match_arrays() */
    size_t    result_size; /* Size of the result array */
    vector_t *result;      /* Result array */
    svalue_t *src;         /* Pointer for getting the result elements */
    svalue_t *dest;        /* Pointer for storing the result elements */
    size_t i;

    size_t vec1_size = VEC_SIZE(vec1);
    size_t vec2_size = VEC_SIZE(vec2);
    size_t sum_size = vec1_size + vec2_size;

    /* Handle empty arrays quickly */

    if (vec1_size == 0)
    {
        free_array(vec1);
        return vec2;
    }

    if (vec2_size == 0)
    {
        free_array(vec2);
        return vec1;
    }

    /* Non-trivial arrays: match them up */
    flags = match_arrays(vec1, vec2);

    /* Count how many elements have to be copied
     * and allocate the result array.
     */
    for (i = result_size = 0; i < sum_size; i++)
    {
        if (!flags[i])
            result_size++;
    }

    if (max_array_size && result_size > max_array_size)
    {
        xfree(flags);
        errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
    }

    result = allocate_array(result_size);

    /* Copy the elements to keep from vec1 into result.
     * We count down result_size to be able to stop as early
     * as possible.
     */
    dest = result->item;
    for ( src = vec1->item, i = 0
        ; i < vec1_size && result_size != 0
        ; i++, src++
        )
    {
        if (!flags[i])
        {
            assign_svalue_no_free(dest, src);
            dest++;
            result_size--;
        }
    }

    /* Copy the elements to keep from vec2 into result, starting
     * at the current position <dest>.
     * We count down result_size to be able to stop as early
     * as possible.
     */
    for ( src = vec2->item, i = vec1_size
        ; i < sum_size && result_size != 0
        ; i++, src++
        )
    {
        if (!flags[i])
        {
            assign_svalue_no_free(dest, src);
            dest++;
            result_size--;
        }
    }

    /* Cleanup and return */
    xfree(flags);
    free_array(vec1);
    free_array(vec2);

    return result;
} /* symmetric_diff_array() */

/*-------------------------------------------------------------------------*/
Bool
is_ordered (vector_t *v)

/* Determine if <v> satisfies the conditions for being an ordered vector.
 * Return true if yes, false if not.
 *
 * The conditions are:
 *   - every string is shared
 *   - all elements are sorted according to rvalue_cmp().
 *
 * This predicate is currently used just by the swapper, historically
 * to avoid swapping out alist values. This is because the internal order
 * is based on pointer values and thus unreproducible.
 */

{
    svalue_t *svp;
    mp_int i;

    for (svp = v->item, i = (mp_int)VEC_SIZE(v); --i > 0; svp++) {
        if ((svp->type == T_STRING || svp->type == T_BYTES) && !mstr_tabled(svp->u.str))
            return MY_FALSE;
        if (rvalue_cmp(svp, svp+1) > 0)
            return MY_FALSE;
    }
    if ((svp->type == T_STRING || svp->type == T_BYTES) && !mstr_tabled(svp->u.str))
        return MY_FALSE;

    return MY_TRUE;
} /* is_ordered() */

/*=========================================================================*/

/*                            EFUNS                                        */

/*-------------------------------------------------------------------------*/
/* This structure has all information for the cleanup handler.
 * So it contains the full state of the allocate() algorithm.
 * (Except the current dimension, which we can deduct easily.)
 */
struct allocate_cleanup_s
{
    error_handler_t head; /* For push_error_handler.                 */

    int num_dim;          /* Number of dimensions.                   */
    bool hasInitValue;    /* True, if there are special init values. */

    size_t * curpos;      /* For each dimension the number of initialized array elements. */
    size_t * sizes;       /* For each dimension the final array size.                     */
    vector_t ** curvec;   /* For each dimension the array that's being worked on.         */
};

/*-------------------------------------------------------------------------*/
static void
allocate_cleanup (error_handler_t *arg)

/* Cleanup handler for the allocate() efun.
 *
 * This is called when an error happens during the allocation
 * of an array and cleans up the partly created array.
 */

{
    struct allocate_cleanup_s* info = (struct allocate_cleanup_s*)arg;

    int dim = info->num_dim - 1;
    while (dim >= 0)
    {
        if (info->curvec[dim])
            break;

        dim--;
    }

    while (dim >= 0)
    {
        if (!info->curpos[dim])
        {
            /* Finished this array. */
            xfree(info->curvec[dim]);
            dim--;
        }
        else if (dim != info->num_dim - 1)
        {
            /* Go to the next dimension. */
            size_t pos = --info->curpos[dim];

            info->curvec[dim+1] = info->curvec[dim]->item[pos].u.vec;
            info->curpos[dim+1] = info->sizes[dim+1];
            dim++;
        }
        else if (info->hasInitValue)
        {
            size_t pos = --info->curpos[dim];

            free_svalue(info->curvec[dim]->item + pos);
        }
        else
        {
            /* All elements are zero, don't need to free them. */
            info->curpos[dim] = 0;
        }
    }
}

/*-------------------------------------------------------------------------*/
svalue_t *
v_allocate (svalue_t *sp, int num_arg)

/* EFUN allocate()
 *
 *     mixed *allocate(int|int* size)
 *     mixed *allocate(int|int* size, mixed init_value)
 *
 * Allocate an array of <size> elements (if <size> is an array, the result
 * will be a multidimensional array), either empty or all
 * elements initialized with <init_value>. If <init_value> is a
 * mapping or array, allocate will create shallow copies of them.
 */

{
    static struct allocate_cleanup_s info;
    vector_t *v;
    svalue_t *argp;
    size_t new_size;

    argp = sp - num_arg + 1;

    if (argp->type == T_NUMBER)
    {
        new_size = (size_t)argp->u.number;

        if (num_arg == 1 || (sp->type == T_NUMBER && !sp->u.number))
            v = allocate_array(new_size);
        else
        {
            size_t i;
            svalue_t *svp;

            v = allocate_uninit_array(new_size);

            info.num_dim = 1;
            info.hasInitValue = true;
            info.curpos = &i;
            info.sizes = &new_size;
            info.curvec = &v;

            /* In case of an (out of memory) error... */
            push_error_handler(allocate_cleanup, &(info.head));

            for (svp = v->item, i = 0; i < new_size; i++, svp++)
                copy_svalue_no_free(svp, sp);

            /* Remove the cleanup routine without starting it. */
            inter_sp = sp;
        }
    }
    else if (argp->type == T_POINTER
          && (    VEC_SIZE(argp->u.vec) == 0
               || (   VEC_SIZE(argp->u.vec) == 1
                   && argp->u.vec->item->type == T_NUMBER
                   && argp->u.vec->item->u.number == 0)
             )
            )
    {
        /* Special case: result is the empty array.
         * The condition catches ( ({}) ) as well as ( ({0}) )
         * (the generic code below can only handle the later).
         */
        v = allocate_array(0);
    }
    else if (argp->type == T_POINTER)
    {
        svalue_t *svp;
        size_t dim;
        size_t count;

        info.num_dim = VEC_SIZE(argp->u.vec);
        info.hasInitValue = MY_FALSE;

        info.curpos = alloca(VEC_SIZE(argp->u.vec) * sizeof(*info.curpos));
        info.sizes = alloca(VEC_SIZE(argp->u.vec) * sizeof(*info.sizes));
        info.curvec = alloca(VEC_SIZE(argp->u.vec) * sizeof(*info.curvec));

        if (!info.curpos || !info.curvec || !info.sizes)
        {
            errorf("Out of stack memory.\n");
            /* NOTREACHED */
        }

        if (num_arg == 2 && (sp->type != T_NUMBER || sp->u.number != 0))
        {
            info.hasInitValue = MY_TRUE;
        }

        /* Check the size array for consistency, and also count how many
         * elements we're going to allocate.
         */
        for ( dim = 0, count = 0, svp = argp->u.vec->item
            ; dim < info.num_dim
            ; dim++, svp++
            )
        {
            p_int size;
            svalue_t *item = get_rvalue(svp, NULL);

            if (item == NULL)
                item = svp;

            if (item->type != T_NUMBER)
            {
                errorf("Bad argument to allocate(): size[%d] is a '%s', "
                      "expected 'int'.\n"
                     , (int)dim, typename(item->type));
                /* NOTREACHED */
            }

            size = item->u.number;

            if (size < 0 || (max_array_size && (size_t)size > max_array_size))
                errorf("Illegal array size: %"PRIdPINT"\n", size);

            if (size == 0 && dim < info.num_dim-1)
                errorf("Only the last dimension can have empty arrays.\n");

            count *= (size_t)size;
            if (max_array_size && count > max_array_size)
                errorf("Illegal total array size: %lu\n", (unsigned long)count);

            info.sizes[dim] = (size_t)size;
            info.curvec[dim] = NULL;
        }

        /* Now loop over the dimensions, creating the array structure */
        dim = 0;
        info.curpos[0] = 0;

        push_error_handler(allocate_cleanup, &(info.head));

        while (dim > 0 || info.curpos[0] < info.sizes[0])
        {
            if (!info.curvec[dim])
            {
                /* We just entered this dimension.
                 * Create a new array and initialise the loop.
                 */
                if (info.hasInitValue || dim+1 < info.num_dim)
                {
                    info.curvec[dim] = allocate_uninit_array(info.sizes[dim]);
                }
                else
                {
                    info.curvec[dim] = allocate_array(info.sizes[dim]);
                    /* This is the last dimension, and there is nothing
                     * to initialize: return immediately to the higher level
                     */
                    info.curpos[dim] = info.sizes[dim]; /* In case dim == 0 */
                    if (dim > 0)
                        dim--;
                    continue;
                }
                info.curpos[dim] = 0;
            }

            /* curvec[dim] is valid, and we have to put the next
             * element in at index curpos[dim].
             */
            if (dim == info.num_dim-1)
            {
                /* Last dimension: assign the init value */
                if (info.hasInitValue && info.curpos[dim] < info.sizes[dim])
                    copy_svalue_no_free(info.curvec[dim]->item+info.curpos[dim], sp);
            }
            else if (!info.curvec[dim+1])
            {
                /* We need a vector from a lower dimension, but it doesn't
                 * exist yet: setup the loop parameters to go into
                 * that lower level.
                 */
                dim++;
                continue;
            }
            else if (info.curpos[dim] < info.sizes[dim])
            {
                /* We got a vector from a lower lever */
                put_array(info.curvec[dim]->item+info.curpos[dim], info.curvec[dim+1]);
                info.curvec[dim+1] = NULL;
            }

            /* Continue to the next element. If we are at the end
             * of this dimension, return to the next higher one.
             */
            info.curpos[dim]++;
            if (info.curpos[dim] >= info.sizes[dim] && dim > 0)
            {
                dim--;
            }
        } /* while() */

        /* The final vector is now in curvec[0] */
        if (!info.curvec[0])
            v = ref_array(&null_vector);
        else
            v = info.curvec[0];

        /* Remove the cleanup routine without starting it. */
        inter_sp = sp;
    }
    else
    {
        /* The type checker should prevent this case */
        fatal("Illegal arg 1 to allocate(): got '%s', expected 'int|int*'.\n"
             , typename(argp->type));
    } /* if (argp->type) */

    if (num_arg == 2)
        free_svalue(sp--);

    free_svalue(sp);
    put_array(sp, v);

    return sp;
} /* v_allocate() */

/*-------------------------------------------------------------------------*/
svalue_t *
x_filter_array (svalue_t *sp, int num_arg)

/* EFUN: filter() for arrays.
 *
 *   mixed *filter(mixed *arr, string fun)
 *   mixed *filter(mixed *arr, string fun, string|object obj, mixed extra, ...)
 *   mixed *filter(mixed *arr, closure cl, mixed extra, ...)
 *   mixed *filter(mixed *arr, mapping map)
 *
 * Filter the elements of <arr> through a filter defined by the other
 * arguments, and return an array of those elements, for which the
 * filter yields non-zero.
 *
 * The filter can be a function call:
 *
 *    <obj>-><fun>(elem, <extra>...)
 *
 * or a mapping query:
 *
 *    <map>[elem]
 *
 * <obj> can both be an object reference or a filename. If omitted,
 * this_object() is used (this also works if the third argument is
 * neither a string nor an object).
 *
 * As a bonus, all references to destructed objects in <arr> are replaced
 * by proper 0es.
 *
 * TODO: Autodoc-Feature to create doc/efun/filter_array automatically.
 */

{
    svalue_t *arg;    /* First argument the vm stack */
    vector_t *p;      /* The filtered vector */
    mp_int    p_size; /* sizeof(*p) */
    vector_t *vec;
    svalue_t *v, *w;
    char     *flags;  /* Flag array, one flag for each element of <p>
                       * (in reverse order) */
    int       res;    /* Number of surviving elements */
    int       cnt;

    res = 0;

    /* Locate the args on the stack, extract the vector to filter
     * and allocate the flags vector.
     */
    arg = sp - num_arg + 1;

    p = arg->u.vec;
    p_size = (mp_int)VEC_SIZE(p);

    flags = alloca((size_t)p_size+1);
    if (!flags)
    {
        errorf("Stack overflow in filter()");
        /* NOTREACHED */
        return sp;
    }

    /* Every element in flags is associated by index number with an
     * element in the vector to filter. The filter function is evaluated
     * for every vector element, and the associated flag is set to 0
     * or 1 according to the result.
     * At the end, all 1-flagged elements are gathered and copied
     * into the result vector.
     */

    if (arg[1].type == T_MAPPING) {

        /* --- Filter by mapping query --- */
        mapping_t *m;

        if (num_arg > 2) {
            inter_sp = sp;
            errorf("Too many arguments to filter(array)\n");
        }
        m = arg[1].u.map;

        for (w = p->item, cnt = p_size; --cnt >= 0; )
        {
            if (destructed_object_ref(w))
                assign_svalue(w, &const0);
            if (get_map_value(m, w++) == &const0) {
                flags[cnt] = 0;
                continue;
            }
            flags[cnt] = 1;
            res++;
        }

        free_svalue(arg+1);
        sp = arg;

    } else {

        /* --- Filter by function call --- */

        int         error_index;
        callback_t *cb;

        assign_eval_cost();
        inter_sp = sp;

        error_index = setup_efun_callback(&cb, arg+1, num_arg-1);

        if (error_index >= 0)
        {
            vefun_bad_arg(error_index+2, arg);
            /* NOTREACHED */
            return arg;
        }
        inter_sp = sp = arg+1;
        put_callback(sp, cb);

        /* Loop over all elements in p and call the filter.
         * w is the current element filtered.
         */
        for (w = p->item, cnt = p_size; --cnt >= 0; )
        {
            flags[cnt] = 0;

            if (is_current_object_destructed())
                continue;
                /* Don't call the filter anymore, but fill the
                 * flags array with 0es.
                 */

            if (destructed_object_ref(w))
                assign_svalue(w, &const0);

            if (!valid_callback_object(cb))
            {
                inter_sp = sp;
                errorf("object used by filter(array) destructed");
            }

            push_rvalue(w++);

            v = apply_callback(cb, 1);
            if (!v || (v->type == T_NUMBER && !v->u.number) )
                continue;

            flags[cnt] = 1;
            res++;
        }

        pop_stack();
    }

    /* flags[] holds the filter results, res is the number of
     * elements to keep. Now create the result vector.
     */
    vec = allocate_array(res);
    if (res) {
        for(v = p->item, w = vec->item, flags = &flags[p_size]; ; v++) {
            if (*--flags) {
                assign_rvalue_no_free (w++, v);
                if (--res <= 0) break;
            }
        }
    }

    /* Cleanup (everything but the array has been removed already) */
    free_array(p);
    arg->u.vec = vec;

    return arg;
} /* x_filter_array() */

/*-------------------------------------------------------------------------*/
svalue_t *
x_map_array (svalue_t *sp, int num_arg)

/* EFUN map() on arrays
 *
 *   mixed * map(mixed * arg, string func, string|object ob, mixed extra...)
 *   mixed * map(mixed * arg, closure cl, mixed extra...)
 *   mixed * map(mixed * arr, mapping map [, int col])
 *
 * Map the elements of <arr> through a filter defined by the other
 * arguments, and return an array of the elements returned by the filter.
 *
 * The filter can be a function call:
 *
 *    <obj>-><fun>(elem, <extra>...)
 *
 * or a mapping query:
 *
 *    <map>[elem[,idx]]
 *
 * In the mapping case, if <map>[elem[,idx]] does not exist, the original
 * value is returned in the result.
 * [Note: argument type and range checking for idx is done in v_map()]
 *
 * <obj> can both be an object reference or a filename. If <ob> is
 * omitted, or neither an object nor a string, then this_object() is used.
 *
 * As a bonus, all references to destructed objects in <arr> are replaced
 * by proper 0es.
 */

{
    vector_t   *arr;
    vector_t   *res;
    svalue_t   *arg;
    svalue_t   *v, *w, *x;
    mp_int      cnt;

    inter_sp = sp;

    arg = sp - num_arg + 1;

    arr = arg->u.vec;
    cnt = (mp_int)VEC_SIZE(arr);

    if (arg[1].type == T_MAPPING)
    {
        /* --- Map through mapping --- */

        mapping_t *m;
        p_int column = 0; /* mapping column to use */

        m = arg[1].u.map;

        if (num_arg > 2)
            column = arg[2].u.number;

        res = allocate_array(cnt);
        if (!res)
            errorf("(map_array) Out of memory: array[%"PRIdMPINT
                "] for result\n", cnt);
        push_array(inter_sp, res); /* In case of errors */

        for (w = arr->item, x = res->item; --cnt >= 0; w++, x++)
        {
            if (destructed_object_ref(w))
                assign_svalue(w, &const0);

            v = get_map_value(m, w);
            if (v == &const0)
                assign_rvalue_no_free(x, w);
            else
                assign_rvalue_no_free(x, v + column);
        }

        if (num_arg > 2)
            free_svalue(arg+2);
        free_svalue(arg+1); /* the mapping */
        sp = arg;
    }
    else
    {
        /* --- Map through function call --- */

        callback_t *cb;
        int         error_index;

        error_index = setup_efun_callback(&cb, arg+1, num_arg-1);
        if (error_index >= 0)
        {
            vefun_bad_arg(error_index+2, arg);
            /* NOTREACHED */
            return arg;
        }
        inter_sp = sp = arg+1;
        put_callback(sp, cb);
        num_arg = 2;

        res = allocate_array(cnt);
        if (!res)
            errorf("(map_array) Out of memory: array[%"PRIdMPINT
                "] for result\n", cnt);
        push_array(inter_sp, res); /* In case of errors */

        /* Loop through arr and res, mapping the values from arr */
        for (w = arr->item, x = res->item; --cnt >= 0; w++, x++)
        {
            if (is_current_object_destructed())
                continue;

            if (destructed_object_ref(w))
                assign_svalue(w, &const0);

            if (!valid_callback_object(cb))
                errorf("object used by map(array) destructed");

            push_rvalue(w);

            v = apply_callback(cb, 1);
            if (v)
            {
                transfer_rvalue_no_free(x, v);
                v->type = T_INVALID;
            }
        }

        free_svalue(inter_sp - 1); /* The callback. */
    }

    /* The arguments have been removed already, now just replace
     * the arr on the stack with the result.
     */
    free_array(arr);
    arg->u.vec = res; /* Keep svalue type: T_POINTER */

    return arg;
} /* x_map_array () */

/*-------------------------------------------------------------------------*/
svalue_t *
v_sort_array (svalue_t * sp, int num_arg)

/* EFUN sort_array()
 *
 *   mixed *sort_array(mixed *arr, string wrong_order
 *                               , object|string ob, mixed extra...)
 *   mixed *sort_array(mixed *arr, closure cl, mixed extra...)
 *
 * Create a shallow copy of array <arr> and sort that copy by the ordering
 * function ob->wrong_order(a, b), or by the closure expression 'cl'.
 * The sorted copy is returned as result.
 *
 * If the 'arr' argument equals 0, the result is also 0.
 * 'ob' is the object in which the ordering function is called
 * and may be given as object or by its filename.
 * If <ob> is omitted, or neither an object nor a string, then
 * this_object() is used.
 *
 * The elements from the array to be sorted are passed in pairs to
 * the function 'wrong_order' as arguments, followed by any <extra>
 * arguments.
 *
 * The function should return a positive number if the elements
 * are in the wrong order. It should return 0 or a negative
 * number if the elements are in the correct order.
 *
 * The sorting is implemented using Mergesort, which gives us a O(N*logN)
 * worst case behaviour and provides a stable sort.
 */

{
    vector_t   *data;
    svalue_t   *arg;
    svalue_t   *items = NULL;
    callback_t *cb;
    int         error_index;
    mp_int      step, halfstep, offset, size;
    int         i, j, index1, index2, end1, end2;
    svalue_t   *source, *dest, *temp;
    Bool        inplace = MY_FALSE;
    
    arg = sp - num_arg + 1;

    error_index = setup_efun_callback(&cb, arg+1, num_arg-1);
    if (error_index >= 0)
    {
        vefun_bad_arg(error_index+2, arg);
        /* NOTREACHED */
        return arg;
    }
    inter_sp = sp = arg+1;
    put_callback(sp, cb);
    num_arg = 2;

    /* If the argument is passed in by reference, make sure that it is
     * an array, place the argument vector directly into the stack and set
     * inplace.
     */
    if (arg->type == T_LVALUE)
    {
        svalue_t * svp = get_rvalue(arg, NULL);

        if (svp == NULL)
        {
            /* This is a range. */
            switch (arg->x.lvalue_type)
            {
                case LVALUE_PROTECTED_RANGE:
                {
                    struct protected_range_lvalue *r = arg->u.protected_range_lvalue;

                    if (r->vec.type != T_POINTER)
                    {
                        inter_sp = sp;
                        errorf("Bad arg 1 to sort_array(): got '%s[..] &', "
                               "expected 'mixed * / mixed *&'.\n"
                               , typename(r->vec.type));
                        // NOTREACHED
                        return sp;
                    }

                    offset = r->index1;
                    size = r->index2 - r->index1;
                    data = r->vec.u.vec;
                    break;
                }

                case LVALUE_PROTECTED_MAP_RANGE:
                {
                    struct protected_map_range_lvalue *r = arg->u.protected_map_range_lvalue;

                    items = get_map_value(r->map, &(r->key));
                    if (items == &const0)
                    {
                        /* Not existing entries are all zeroes, so they are sorted. */
                        pop_stack();
                        return arg;
                    }

                    data = NULL;
                    offset = r->index1;
                    size = r->index2 - r->index1;
                    break;
                }

                default:
                    fatal("Illegal lvalue type %d\n", arg->x.lvalue_type);
                    break;
            }
        }
        else if (svp->type == T_POINTER)
        {
            data = ref_array(svp->u.vec);
            free_svalue(arg);
            put_array(arg, data);

            offset = 0;
            size = (mp_int)VEC_SIZE(data);
        }
        else
        {
            inter_sp = sp;
            errorf("Bad arg 1 to sort_array(): got '%s &', "
                   "expected 'mixed * / mixed *&'.\n"
                   , typename(svp->type));
            // NOTREACHED
            return sp;
        }

        inplace = MY_TRUE;

    }
    else
    {
        offset = 0;
        size = (mp_int)VEC_SIZE(arg->u.vec);
        data = arg->u.vec;
    }

    if (data)
        check_for_destr(data);
    else
    {
        for (i = 0; i < size; i++)
        {
            if (destructed_object_ref(items + offset + i))
                assign_svalue(items + offset + i, &const0);
        }
    }

    /* Get the array. Since the sort sorts in-place, we have
     * to make a shallow copy of arrays with more than one
     * ref. Exception is, if the array is given as reference/lvalue, then we
     * always sort in-place.
     */

    if (!inplace && data->ref != 1)
    {
        vector_t *vcopy;

        vcopy = slice_array(data, 0, VEC_SIZE(data)-1);
        free_array(data);
        data = vcopy;
        arg->u.vec = data;
    }

    if (data)
        items = data->item;
    /* Otherwise it was already initialized
     * (LVALUE_PROTECTED_MAP_RANGE case).
     */

    /* Easiest case: nothing to sort */
    if (size <= 1)
    {
        pop_stack();
        return arg;
    }

    /* In order to provide clean error recovery, data must always hold
     * exactly one copy of each original content svalue when an error is
     * possible. Thus, it would be not a good idea to use it as scrap
     * space.
     */
    source = alloca(size*sizeof(svalue_t));
    dest = alloca(size*sizeof(svalue_t));
    if (!source || !dest)
    {
        errorf("Stack overflow in sort_array()");
        /* NOTREACHED */
        return arg;
    }

    for (i = 0; i < size; i++)
        source[i] = items[offset+i];

    step = 2;
    halfstep = 1;
    while (halfstep<size)
    {
        for (i = j = 0; i < size; i += step)
        {
            index1 = i;
            index2 = i + halfstep;
            end1 = index2;
            if (end1 > size)
                end1 = size;
            end2 = i + step;
            if (end2 > size)
                end2 = size;

            while (index1 < end1 && index2 < end2)
            {
                svalue_t *d;

                if (!valid_callback_object(cb))
                    errorf("object used by sort_array destructed");

                push_svalue(source+index1);
                push_svalue(source+index2);
                d = apply_callback(cb, 2);

                if (d && (d->type != T_NUMBER || d->u.number > 0))
                    dest[j++] = source[index2++];
                else
                    dest[j++] = source[index1++];
            }

            if (index1 == end1)
            {
                while (index2 < end2)
                    dest[j++] = source[index2++];
            }
            else
            {
                while (index1 < end1)
                    dest[j++] = source[index1++];
            }
        }
        halfstep = step;
        step += step;
        temp = source;
        source = dest;
        dest = temp;
    }

    for (i = size; --i >= 0; )
      items[offset+i] = source[i];

    pop_stack();
    return arg;
} /* v_sort_array() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_filter_objects (svalue_t *sp, int num_arg)

/* EFUN filter_objects()
 *
 *   <object|lwobject> *filter_objects (<object|lwobject> *arr,
 *                                      string fun, mixed extra, ...)
 *
 * Filter the objects in <arr> by calling the lfun obj-><fun>(<extra>...)
 * and return an array of those objects for which the lfun call yields
 * non-zero.
 *
 * The objects can be true objects or filenames. In the latter case, the
 * function tries to load the object before calling the lfun. Any non-object
 * element in <arr> is ignored and thus not included in the result.
 *
 * As a bonus, all references to destructed objects in <arr> are replaced
 * by proper 0es.
 */

{
    vector_t *p;          /* The <arr> argument */
    string_t *func;       /* The <fun> argument */
    svalue_t *arguments;  /* Beginning of 'extra' arguments on vm stack */
    vector_t *w;          /* Result vector */
    CBool *flags = NULL;  /* Flag array, one flag for each element of <p> */
    int res;              /* Count of objects to return */
    mp_int p_size;        /* Size of <p> */
    int cnt = 0;
    svalue_t *v;

    assign_eval_cost();
    inter_sp = sp; /* needed for errors in allocate_array(), apply() */

    /* Locate the arguments on the stack and extract them */
    arguments = sp-num_arg+3;

    p = arguments[-2].u.vec;
    func = arguments[-1].u.str;
    num_arg -= 2;

    p_size = (mp_int)VEC_SIZE(p);

    /* Call <func> in every object, recording the result in flags.
     *
     * Every element in flags is associated by index number with an
     * element in the vector to filter. The filter function is evaluated
     * for every vector element, and the associated flag is set to 0
     * or 1 according to the result.
     * At the end, all 1-flagged elements are gathered and copied
     * into the result vector.
     *
     * Checking if <func> exists as shared string takes advantage of
     * the fact that every existing lfun name is stored as shared string.
     * If it's not shared, no object implements it and we can skip
     * the whole function call loop.
     */

    res = 0;

    func = find_tabled(func);
    if (NULL != func)
    {
        flags = alloca((p_size+1)*sizeof(*flags));
        if (!flags)
        {
            errorf("Stack overflow in filter_objects()");
            /* NOTREACHED */
            return NULL;
        }

        for (cnt = 0; cnt < p_size; cnt++)
        {
            object_t *ob = NULL;        /* Object to call */
            lwobject_t *lwob = NULL;    /* Lightweight object to call */

            flags[cnt] = MY_FALSE;
            v = get_rvalue(p->item + cnt, NULL);

            /* Coerce <v> into a (non-destructed) object ob (if necessary
             * by loading it). If that doesn't work, simply continue
             * with the next element.
             */
            if (v == NULL)
                continue;
            if (v->type == T_OBJECT)
            {
                ob = v->u.ob;
                if (ob->flags & O_DESTRUCTED)
                {
                    assign_svalue(v, &const0);
                    continue;
                }
            }
            else if (v->type == T_LWOBJECT)
            {
                lwob = v->u.lwob;
            }
            else if (v->type == T_STRING)
            {
                if ( !(ob = get_object(v->u.str)) )
                    continue;
            }
            else
                continue;

            /* Abort the efun if this_object is destructed (slightly
             * strange place to check for it).
             */
            if (is_current_object_destructed())
                continue;

            /* Call the filter lfun and record the result. */
            push_svalue_block(num_arg, arguments);
            if (lwob)
                v = sapply_lwob(func, lwob, num_arg);
            else
                v = sapply(func, ob, num_arg);

            if ((v) && (v->type!=T_NUMBER || v->u.number) ) {
                flags[cnt] = MY_TRUE;
                res++;
            }
        } /* for() */
    } /* if() */

    /* Now: cnt == p_size, res == number of 'true' flags */

    /* Create the result vector and fill it with all objects for which
     * true flag was recorded.
     */

    w = allocate_array(res); /* might be a 0-elements array */

    if (res) {

        /* Walk through flags/w->item from the end, copying all
         * positively flagged elements from p.
         */

        v = &w->item[res];
        for (;;) {
            if (flags[--cnt])
            {
                /* Copy the element and update the ref-count */

                assign_svalue_no_free(--v, p->item+cnt);

                /* Loop termination check moved in here to save cycles */
                if (v == w->item)
                    break;
            }
        } /* for () */
    } /* if (res) */

    /* Cleanup and return */
    free_array(p);

    do {
        free_svalue(sp--);
    } while(--num_arg >= 0);

    put_array(sp, w);
    return sp;
} /* v_filter_objects() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_map_objects (svalue_t *sp, int num_arg)

/* EFUN map_objects()
 *
 *   mixed *map_objects (<object|lwobject> *arr, string fun, mixed extra, ...)
 *
 * Map the objects in <arr> by calling the lfun obj-><fun>(<extra>...)
 * and return an array of the function call results.
 *
 * The objects can be true objects or filenames. In the latter case, the
 * function tries to load the object before calling the lfun. Any non-object
 * element in <arr> is ignored and a 0 is returned in its place.
 *
 * As a bonus, all references to destructed objects in <arr> are replaced
 * by proper 0es.
 */

{
    vector_t *p;          /* The <arr> argument */
    string_t *func;       /* The <fun> argument */
    svalue_t *arguments;  /* Beginning of 'extra' arguments on vm stack */
    vector_t *r;          /* Result vector */
    mp_int size;          /* Size of <p> */
    int cnt;
    svalue_t *w, *v, *x;

    assign_eval_cost();
    inter_sp = sp;  /* In case of errors leave a clean stack behind */

    arguments = sp-num_arg+3;

    p = arguments[-2].u.vec;
    func = arguments[-1].u.str;
    num_arg -= 2;

    r = allocate_array(size = (mp_int)VEC_SIZE(p));
    arguments[-2].u.vec = r;

    push_array(inter_sp, p); /* Ref it from the stack in case of errors */

    /* Call <func> in every object, storing the result in r.
     *
     * Checking if <func> exists as shared string takes advantage of
     * the fact that every existing lfun name is stored as shared string.
     * If it's not shared, no object implements it and we can skip
     * the whole function call loop.
     */

    func = find_tabled(func);
    if (NULL != func)
    {
        for (cnt = size, v = p->item, x = r->item; --cnt >= 0; v++, x++)
        {
            svalue_t * ob_sv = get_rvalue(v, NULL);
            object_t *ob = NULL;        /* Object to call */
            lwobject_t *lwob = NULL;    /* Lightweight object to call */

            /* Coerce <v> into a (non-destructed) object ob (if necessary
             * by loading it). If that doesn't work, simply continue
             * with the next element.
             */
            if (ob_sv == NULL)
                continue;
            if (ob_sv->type == T_OBJECT)
            {
                ob = ob_sv->u.ob;
                if (ob->flags & O_DESTRUCTED)
                {
                    assign_svalue(ob_sv, &const0);
                    continue;
                }
            }
            else if (ob_sv->type == T_LWOBJECT)
            {
                lwob = ob_sv->u.lwob;
            }
            else if (ob_sv->type == T_STRING)
            {
                if ( !(ob = get_object(ob_sv->u.str)) )
                    continue;
            }
            else
                continue;

            /* Abort the efun if this_object is destructed (slightly
             * strange place to check for it).
             */
            if (is_current_object_destructed())
                continue;

            /* Call the lfun and record the result */
            push_svalue_block(num_arg, arguments);
            if (lwob)
                w = sapply_lwob(func, lwob, num_arg);
            else
                w = sapply (func, ob, num_arg);
            if (w)
            {
                *x = *w;
                w->type = T_INVALID;
            }
        } /* for() */
    } /* if() */

    /* Clean up and return */
    do {
        free_svalue(sp--);
    } while(--num_arg >= 0);
    free_array(p);

    return sp;
} /* v_map_objects() */

/*-------------------------------------------------------------------------*/
svalue_t *
f_transpose_array (svalue_t *sp)

/* EFUN transpose_array()
 *
 *   mixed *transpose_array (mixed *arr);
 *
 * transpose_array ( ({ ({1,2,3}), ({a,b,c}) }) )
 * 		  => ({ ({1,a}), ({2,b)}, ({3,c}) })
 *
 * transpose_array() applied to an alist results in an array of
 * ({ key, data }) pairs, useful if you want to use sort_array()
 * or filter_array() on the alist.
 *
 * TODO: There should be something like this for mappings.
 */

{
    vector_t *src;      /* Input vector */
    vector_t *dest;     /* Result vector */
    mp_int srclen;      /* size of <src> */
    mp_int srcwidth;    /* size of <src>[ix] for all ix */
    bool no_copy;       /* true if <src> has only one ref, else false.  */

    svalue_t *srcitem;  /* item within input vector. */
    svalue_t *destitem; /* item within result vector. */
    mp_int srccount;    /* remaining items in input vector. */
    mp_int srcindex;    /* index within input vector. */
    mp_int destindex;   /* index within result vector. */

    /* Get and test the arguments */
    src = sp->u.vec;

    if ( !(srclen = (mp_int)VEC_SIZE(src)) )
        return sp;

    /* Find the widest subarray in the main array */
    srcwidth = 0;
    for (srcitem = src->item, srccount = srclen; srccount > 0; srccount--, srcitem++)
    {
        svalue_t *entry = get_rvalue(srcitem, NULL);
        mp_int entrylen = -1;

        if (entry == NULL)
        {
            /* This is a range lvalue. */
            assert(srcitem->type == T_LVALUE);
            switch (srcitem->x.lvalue_type)
            {
                case LVALUE_PROTECTED_RANGE:
                {
                    struct protected_range_lvalue *r = srcitem->u.protected_range_lvalue;
                    if (r->vec.type == T_POINTER)
                        entrylen = (mp_int) r->index2 - r->index1;
                    break;
                }

                case LVALUE_PROTECTED_MAP_RANGE:
                {
                    struct protected_map_range_lvalue *r = srcitem->u.protected_map_range_lvalue;
                    entrylen = r->index2 - r->index1;
                    break;
                }

                default:
                    fatal("Illegal lvalue type %d\n", srcitem->x.lvalue_type);
                    break;
            }
        }
        else
        {
            if (entry->type == T_POINTER)
                entrylen = (mp_int)VEC_SIZE(entry->u.vec);
        }

        if (entrylen == -1)
        {
            errorf("Bad arg 1 to transpose_array(): not an array of arrays.\n");
            /* NOTREACHED */
            return sp;
        }

        if (entrylen > srcwidth)
            srcwidth = entrylen;
    }

    /* If all subarrays are empty, just return an empty array */
    if (!srcwidth)
    {
        sp->u.vec = ref_array(&null_vector);
        free_array(src);
        return sp;
    }

    no_copy = (src->ref == 1);

    /* Allocate and initialize the result vector */
    dest = allocate_uninit_array(srcwidth);
    for (destindex = srcwidth, destitem = dest->item; --destindex >= 0; destitem++)
    {
        put_array(destitem, allocate_array(srclen));
    }

    srcindex = 0;
    for (srccount = srclen, srcitem = src->item; --srccount >= 0; srcindex++, srcitem++)
    {
        bool last_reference = false;
        svalue_t *srcentry = get_rvalue(srcitem, &last_reference);
        mp_int srcentrylen;
        svalue_t *srcentryitem = NULL;

        destitem = dest->item;

        if (srcentry == NULL)
        {
            /* This is a range lvalue. */
            assert(srcitem->type == T_LVALUE);
            switch (srcitem->x.lvalue_type)
            {
                case LVALUE_PROTECTED_RANGE:
                {
                    struct protected_range_lvalue *r = srcitem->u.protected_range_lvalue;
                    if (r->vec.type != T_POINTER)
                        break;
                    srcentryitem = r->vec.u.vec->item + r->index1;
                    srcentrylen = (mp_int) r->index2 - r->index1;
                    if (r->vec.u.vec->ref != 1)
                        last_reference = false;
                    break;
                }

                case LVALUE_PROTECTED_MAP_RANGE:
                {
                    struct protected_map_range_lvalue *r = srcitem->u.protected_map_range_lvalue;
                    srcentryitem = get_map_value(r->map, &(r->key));
                    srcentrylen = r->index2 - r->index1;

                    /* The array is already initialized to zero,
                     * no need to do anything if the key is not found.
                     */
                    if (srcentryitem == &const0)
                        continue;

                    srcentryitem += r->index1;
                    if (r->map->ref != 1)
                        last_reference = false;
                    break;
                }

                default:
                    fatal("Illegal lvalue type %d\n", srcitem->x.lvalue_type);
                    break;
            }

            if (!srcentryitem)
                break;
        }
        else
        {
            if (srcentry->type != T_POINTER)
                break;
            srcentryitem = srcentry->u.vec->item;
            srcentrylen = (mp_int)VEC_SIZE(srcentry->u.vec);
            if (srcentry->u.vec->ref != 1)
                last_reference = false;
        }

        if (no_copy && last_reference)
        {
            /* Move the values to the result vector */

            for (mp_int srcentrypos = srcentrylen; srcentrypos; srcentrypos--)
            {
                transfer_rvalue_no_free(destitem->u.vec->item + srcindex, srcentryitem);

                srcentryitem->type = T_INVALID;
                destitem++;
                srcentryitem++;
            }
            free_svalue(srcitem);
            srcitem->type = T_INVALID;
        }
        else
        {
            /* Assign the values to the result vector */

            for (mp_int srcentrypos = srcentrylen; srcentrypos; srcentrypos--)
            {
                assign_rvalue_no_free(destitem->u.vec->item + srcindex, srcentryitem);
                destitem++;
                srcentryitem++;
            }
        }
    }

    /* Clean up and return the result */

    free_array(sp->u.vec);
    sp->u.vec = dest;
    return sp;
} /* f_transpose_array() */

/*=========================================================================*/

/* EFUN unique_array()
 *
 *   <object|lwobject> **unique_array (<object|lwobject> *obarr, string seperator, mixed skip = 0)
 *
 * Group all those objects from <obarr> together for which the
 * <separator> function (which is called in every object) returns the
 * same value. Objects for which the function returns the <skip> value
 * and all non-object elements are omitted fully from the result.
 *
 * The returned array is an array of arrays of objects in the form:
 *
 *       ({ ({ Same1:1, Same1:2, ... Same1:N }),
 *          ({ Same2:1, Same2:2, ... Same2:N }),
 *             ....
 *          ({ SameM:1, SameM:2, ... SameM:N })
 *       })
 *
 * The result of <separator>() (the 'marker value') must be a number,
 * a string, an object or an array.
 *
 * Basic purpose of this efun is to speed up the preparation of an
 * inventory description - e.g. it allows to to fold all objects with
 * identical descriptions into one textline.
 *
 * Other applications are possible, for example:
 *
 *   mixed *arr;
 *   arr=unique_array(users(), "_query_level", -1);
 *
 * This will return an array of arrays holding all user objects
 * grouped together by their user levels. Wizards have a user
 * level of -1 so they will not appear in the the returned array.
 *
 * TODO: Expand unique_array(), e.g. by taking a closure as function
 * TODO:: or provide a simulation.
 * TODO: Allow unique_array() to tag the returned groups with the
 * TODO:: value returned by the separator().
 * TODO: unique_array() is almost big enough for a file on its own.
 */

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

/* The function builds a comb of unique structures: every tooth lists
 * all objects with the same marker value, with the first structure
 * of every tooth linked together to form the spine:
 *
 *   -> Marker1:1 -> Marker1:2 -> ...
 *         |
 *         V
 *      Marker2:1 -> Marker2:2 -> ...
 *         |
 *         V
 *        ...
 */

struct unique
{
    int count;            /* Number of structures in this tooth */
    svalue_t *val;        /* The object itself */
    svalue_t mark;        /* The marker value for this object */
    struct unique *same;  /* Next structure in this tooth */
    struct unique *next;  /* Next tooth head */
};

/*-------------------------------------------------------------------------*/
static int
sameval (svalue_t *arg1, svalue_t *arg2)

/* Return true if <arg1> is identical to <arg2>.
 * For arrays, this function only compares if <arg1> and <arg2> refer
 * to the same array, not the values.
 */

{
    if (!arg1 || !arg2) return 0;
    if (arg1->type == T_NUMBER && arg2->type == T_NUMBER) {
        return arg1->u.number == arg2->u.number;
    } else if (arg1->type == T_POINTER && arg2->type == T_POINTER) {
        return arg1->u.vec == arg2->u.vec;
    } else if (arg1->type == T_STRING && arg2->type == T_STRING) {
        return mstreq(arg1->u.str, arg2->u.str);
    } else if (arg1->type == T_BYTES && arg2->type == T_BYTES) {
        return mstreq(arg1->u.str, arg2->u.str);
    } else if (arg1->type == T_OBJECT && arg2->type == T_OBJECT) {
        return arg1->u.ob == arg2->u.ob;
    } else if (arg1->type == T_LWOBJECT && arg2->type == T_LWOBJECT) {
        return arg1->u.lwob == arg2->u.lwob;
    } else if (arg1->type == T_COROUTINE && arg2->type == T_COROUTINE) {
        return arg1->u.coroutine == arg2->u.coroutine;
    } else
        return 0;
} /* sameval() */


/*-------------------------------------------------------------------------*/
static int
put_in (Mempool pool, struct unique **ulist
       , svalue_t *marker, svalue_t *elem)

/* Insert the object <elem> according to its <marker> value into the comb
 * of unique structures. <ulist> points to the root pointer of this comb.
 * Return the (new) number of distinct markers.
 */

{
    struct unique *llink, *slink, *tlink;
    int cnt;                      /* Number of distinct markers */
    Bool fixed;                   /* True: <elem> was inserted */

    llink = *ulist;
    cnt = 0;
    fixed = 0;

    /* Loop through the comb's top level, counting the distinct marker
     * and searching for the right teeth to insert <elem> into.
     */
    while (llink) {
        if (!fixed && sameval(marker, &(llink->mark))) {

            /* Insert the new <elem> here
             */
            for (tlink = llink; tlink->same; tlink = tlink->same) tlink->count++;
            tlink->count++;
            /* TODO: Is the above really necessary?
             *   slink = new unique; llink->same = slink; llink->count++;
             * should be sufficient.
             */

            slink = mempool_alloc(pool, sizeof(struct unique));
            if (!slink)
            {
                errorf("(unique_array) Out of memory (%lu bytes pooled) "
                      "for comb.\n", (unsigned long)sizeof(struct unique));
                /* NOTREACHED */
                return 0;
            }
            slink->count = 1;
            assign_svalue_no_free(&slink->mark,marker);
            slink->val = elem;
            slink->same = NULL;
            slink->next = NULL;
            tlink->same = slink;

            fixed = 1; /* ...just continue to count now */
            /* TODO: Do not recount the comb size all the time! */
        }

        llink=llink->next;
        cnt++;
    }
    if (fixed)
        return cnt;

    /* It's a really new marker -> start a new tooth in the comb.
     */
    llink = mempool_alloc(pool, sizeof(struct unique));
    if (!llink)
    {
        errorf("(unique_array) Out of memory (%lu bytes pooled) "
              "for comb.\n", (unsigned long)sizeof(struct unique));
        /* NOTREACHED */
        return 0;
    }
    llink->count = 1;
    assign_svalue_no_free(&llink->mark,marker);
    llink->val = elem;
    llink->same = NULL;

    llink->next = *ulist;
    *ulist = llink;

    return cnt+1;
} /* put_in() */


/*-------------------------------------------------------------------------*/
/* To facilitate automatic cleanup of the temporary structures in case
 * of an error, the following structure will be pushed onto the VM stack
 * as T_ERROR_HANDLER.
 */

struct unique_cleanup_s {
    error_handler_t head;  /* The link to the error handler function */
    Mempool         pool;  /* Pool for the unique structures */
    vector_t      * arr;   /* Protective reference to the array */
};

static void
make_unique_cleanup (error_handler_t * arg)
{
    struct unique_cleanup_s * data = (struct unique_cleanup_s *)arg;

    if (data->pool)
        mempool_delete(data->pool);
    if (data->arr)
        deref_array(data->arr);
    xfree(arg);
} /* make_unique_cleanup() */

/*-------------------------------------------------------------------------*/
static vector_t *
make_unique (vector_t *arr, callback_t *cb, svalue_t *skipnum)

/* The actual implementation of efun unique_array();
 *
 * The caller made sure that <arr> contains no destructed objects.
 */

{
    Mempool    pool;      /* Pool for the unique structures */
    svalue_t *v;
    vector_t *ret;        /* Result vector */
    vector_t *res;        /* Current sub vector in ret */
    struct unique *head;  /* Head of the unique comb */
    struct unique *nxt;
    mp_int arr_size;      /* Size of the incoming <arr>ay */
    mp_int ant;           /* Number of distinct markers */
    mp_int cnt, cnt2;
    struct unique_cleanup_s * ucp;

    head = NULL;

    arr_size = (mp_int)VEC_SIZE(arr);

    /* Special case: unifying an empty array */
    if (!arr_size)
        return allocate_array(0);

    /* Get the memory for the arr_size unique-structures we're going
     * to need.
     */
    pool = new_mempool(size_mempool(sizeof(*head)));
    if (!pool)
        errorf("(unique_array) Out of memory: (%lu bytes) for mempool\n"
             , (unsigned long)arr_size * sizeof(*head));

    /* Create the automatic cleanup structure */
    ucp = xalloc(sizeof(*ucp));
    if (!ucp)
    {
        mempool_delete(pool);
        errorf("(unique_array) Out of memory: (%lu bytes) for cleanup structure\n"
             , (unsigned long)sizeof(*ucp));
    }

    ucp->pool = pool;
    ucp->arr = ref_array(arr);  /* Prevent apply from freeing this */

    push_error_handler(make_unique_cleanup, &(ucp->head));

    /* Build the comb structure.
     */
    ant = 0;
    for (cnt = 0; cnt < arr_size; cnt++)
    {
        svalue_t *item;
        if (is_current_object_destructed())
            break;
            /* Don't call the filters anymore */

        item = get_rvalue(arr->item + cnt, NULL);
        if (item == NULL)
            continue;

        if (item->type == T_OBJECT && !destructed_object_ref(item))
        {
            /* It's usually done the other way around, but not here: if
             * it's a closure, we pass the object analyzed; otherwise we
             * change the object the callback is bound to to call the
             * discriminator function in it.
             */
            if (!cb->is_lambda)
                callback_change_object(cb, item->u.ob);
            else
                push_ref_object(inter_sp, item->u.ob, "unique_array");

            v = apply_callback(cb, cb->is_lambda ? 1 : 0);
            if (v && !sameval(v, skipnum))
                ant = put_in(pool, &head, v, item);
        }
        else if (item->type == T_LWOBJECT)
        {
            if (!cb->is_lambda)
                callback_change_lwobject(cb, item->u.lwob);
            else
                push_ref_lwobject(inter_sp, item->u.lwob);

            v = apply_callback(cb, cb->is_lambda ? 1 : 0);
            if (v && !sameval(v, skipnum))
                ant = put_in(pool, &head, v, item);
        }
    }

    ret = allocate_array(ant);

    /* Copy the objects from the comb structure into the result vector,
     * deallocating the structure by this.
     * The elements are stored in reverse to compensate put_in(),
     * but TODO: does someone really care?
     */

    for (cnt = ant-1; cnt >= 0; cnt--) {
        res = allocate_array(head->count);
        put_array(ret->item+cnt, res);

        nxt = head;
        head = head->next;

        cnt2 = 0;
        while (nxt) {
            assign_svalue_no_free (&res->item[cnt2++], nxt->val);
            free_svalue(&nxt->mark);
            nxt = nxt->same;
        }

        if (!head)
            break; /* It shouldn't but, to avoid skydive just in case */
    }

    /* Cleanup using the cleanup structure */
    free_svalue(inter_sp--);

    return ret;
} /* make_unique() */

/*-------------------------------------------------------------------------*/
svalue_t *
v_unique_array (svalue_t *sp, int num_arg)

/* EFUN unique_array()
 *
 *   <object|lwobject>** unique_array(<object|lwobject> *obarr, string|closure fun)
 *   <object|lwobject>** unique_array(<object|lwobject> *obarr, string|closure fun, mixed skip)
 *   <object|lwobject>** unique_array(<object|lwobject> *obarr, string|closure fun, mixed extra..., mixed skip)
 *
 * Groups objects together for which the separator function
 * returns the same value. obarr should be an array of objects,
 * other types are ignored.
 *
 * If the separator function is defined by name, it is searched and called
 * in the objects from <obarr>. If <extra> arguments are given, they are
 * passed to the function as arguments.
 *
 * If the separator function is defined as a closure, it will be passed
 * the objects from <obarr> as first argument, with the <extra> arguments
 * (if any) passed following.
 *
 * If the <skip> argument is given (it is required when <extra> arguments
 * are to be used), and the return value from the separator function call
 * matches this value, the object in question will _not_ be included in the
 * returned array. Default value for <skip> is the number 0.
 */

{
    vector_t *res;
    svalue_t *argp = sp - num_arg + 1;

    check_for_destr(argp->u.vec);

    /* Sort out the arguments */
    if (num_arg == 2)
    {
        /* Just the callback function name on the stack: add the default
         * 'skip' value
         */
        sp++;
        put_number(sp, 0);
    }

    {
        /* Extract the callback information from the stack */
        int         error_index;
        callback_t *cb;

        assign_eval_cost();
        inter_sp = sp;

        error_index = setup_efun_callback_noobj(&cb, argp+1, num_arg-2);

        if (error_index >= 0)
        {
            /* The callback values have already been removed, now
             * make sure that the 'skip' value isn't left out either
             */
            transfer_svalue_no_free(argp+1, sp);
            inter_sp = sp = argp+1;
            vefun_bad_arg(error_index+2, argp+1);
            /* NOTREACHED */
            return argp;
        }

        /* Callback creation successful, now setup the stack */
        put_callback(argp+1, cb);
        transfer_svalue_no_free(argp+2, sp);

        inter_sp = sp = argp+2;
    }

    /* At this point:       argp[0]: the vector
     *                      argp[1]: the callback structure
     *                sp -> argp[2]: the skip value
     */
    res = make_unique(argp->u.vec, argp[1].u.cb, argp+2);

    /* Clean up the stack and push the result */
    free_svalue(sp--);
    free_svalue(sp--);
    free_svalue(sp);

    if (res)
        put_array(sp, res);
    else
        put_number(sp, 0);

    return sp;
} /* v_unique_array() */

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