mirror of
git://git.psyced.org/git/psyclpc
synced 2024-08-15 03:20:16 +00:00
3210 lines
89 KiB
C
3210 lines
89 KiB
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.
|
||
|
*
|
||
|
* LOCAL_VEC1(name, type1)
|
||
|
* LOCAL_VEC2(name, type1, type2)
|
||
|
* Construct a local vector instance named <name> with 1(2)
|
||
|
* elements of type <type1> (and <type2>). Both elements are
|
||
|
* initialised to 0, and the actual vector can be accessed
|
||
|
* as '<name>.v'.
|
||
|
*
|
||
|
* 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 <stddef.h>
|
||
|
|
||
|
#include "array.h"
|
||
|
#include "backend.h"
|
||
|
#include "closure.h" /* closure_cmp(), closure_eq() */
|
||
|
#include "interpret.h" /* for the efuns */
|
||
|
#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-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 - 1))
|
||
|
|
||
|
/* 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), { { T_INVALID } } };
|
||
|
/* 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: %ld.\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[%ld]\n", n);
|
||
|
#else
|
||
|
(*allocate_array_error_handler)
|
||
|
("(%s:%d) Out of memory: array[%ld]\n"
|
||
|
MTRACE_PASS, n);
|
||
|
#endif
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
p->ref = 1;
|
||
|
p->size = n;
|
||
|
if (current_object)
|
||
|
(p->user = current_object->user)->size_array += n;
|
||
|
else
|
||
|
(p->user = &default_wizlist_entry)->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: %ld.\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[%ld]\n", n);
|
||
|
#else
|
||
|
(*allocate_array_error_handler)
|
||
|
("(%s:%d) Out of memory: unlimited array[%ld]\n"
|
||
|
MTRACE_PASS, n);
|
||
|
#endif
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
p->ref = 1;
|
||
|
p->size = n;
|
||
|
if (current_object)
|
||
|
(p->user = current_object->user)->size_array += n;
|
||
|
else
|
||
|
(p->user = &default_wizlist_entry)->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: %ld.\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[%ld]\n", n);
|
||
|
#else
|
||
|
(*allocate_array_error_handler)
|
||
|
("(%s:%d) Out of memory: uninited array[%ld]\n"
|
||
|
MTRACE_PASS, n);
|
||
|
#endif
|
||
|
return 0;
|
||
|
}
|
||
|
|
||
|
p->ref = 1;
|
||
|
p->size = n;
|
||
|
if (current_object)
|
||
|
(p->user = current_object->user)->size_array += n;
|
||
|
else
|
||
|
(p->user = &default_wizlist_entry)->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 %ld 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);
|
||
|
}
|
||
|
|
||
|
/*-------------------------------------------------------------------------*/
|
||
|
static INLINE vector_t *
|
||
|
i_shrink_array (vector_t *p, mp_int n)
|
||
|
|
||
|
/* Create and return a new array containing just the first <n> elements
|
||
|
* of <p>. <p> itself is freed (and thus possibly deallocated).
|
||
|
*/
|
||
|
|
||
|
{
|
||
|
vector_t *res;
|
||
|
|
||
|
if (p->ref == 1 && VEC_SIZE(p) == n)
|
||
|
return p;
|
||
|
/* This case seems to happen often enough to justify
|
||
|
* the shortcut
|
||
|
*/
|
||
|
|
||
|
if (n)
|
||
|
{
|
||
|
res = slice_array(p, 0, n-1);
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
res = ref_array(&null_vector);
|
||
|
}
|
||
|
free_array(p);
|
||
|
return res;
|
||
|
}
|
||
|
|
||
|
vector_t * shrink_array (vector_t *p, mp_int n) { return i_shrink_array(p, n); }
|
||
|
|
||
|
#define shrink_array(p,n) i_shrink_array(p,n)
|
||
|
|
||
|
/*-------------------------------------------------------------------------*/
|
||
|
void
|
||
|
set_vector_user (vector_t *p, object_t *owner)
|
||
|
|
||
|
/* Wizlist statistics: take vector <p> from its former owner and account it
|
||
|
* under its new <owner>.
|
||
|
*/
|
||
|
|
||
|
{
|
||
|
svalue_t *svp;
|
||
|
mp_int i;
|
||
|
|
||
|
i = (mp_int)VEC_SIZE(p);
|
||
|
if (p->user)
|
||
|
p->user->size_array -= i;
|
||
|
if ( NULL != (p->user = owner->user) )
|
||
|
p->user->size_array += i;
|
||
|
svp = p->item;
|
||
|
for (; --i >= 0; svp++) {
|
||
|
set_svalue_user(svp, owner);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/*-------------------------------------------------------------------------*/
|
||
|
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) - sizeof(svalue_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", ""}
|
||
|
*/
|
||
|
|
||
|
{
|
||
|
char *p, *beg;
|
||
|
long num;
|
||
|
long len, left;
|
||
|
vector_t *ret;
|
||
|
string_t *buff;
|
||
|
|
||
|
len = (long)mstrsize(del);
|
||
|
|
||
|
/* --- Special case: Delimiter is an empty or one-char string --- */
|
||
|
if (len <= 1) {
|
||
|
|
||
|
/* Delimiter is empty: return an array which holds all characters as
|
||
|
* single-character strings.
|
||
|
*/
|
||
|
if (len < 1) {
|
||
|
svalue_t *svp;
|
||
|
|
||
|
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);
|
||
|
if (!buff) {
|
||
|
free_array(ret);
|
||
|
outofmem(1, "explode() on a string");
|
||
|
}
|
||
|
put_string(svp, buff);
|
||
|
}
|
||
|
return ret;
|
||
|
|
||
|
}
|
||
|
|
||
|
/* Delimiter is one-char string: speedy implementation which uses
|
||
|
* direct character comparisons instead of calls to memcmp().
|
||
|
*/
|
||
|
else {
|
||
|
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);
|
||
|
if (!buff) {
|
||
|
free_array(ret);
|
||
|
outofmem(len, "explode() on a string");
|
||
|
}
|
||
|
put_string(svp, buff);
|
||
|
}
|
||
|
|
||
|
/* 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);
|
||
|
if (!buff) {
|
||
|
free_array(ret);
|
||
|
outofmem(len, "explode() on a string");
|
||
|
}
|
||
|
put_string(svp, buff);
|
||
|
|
||
|
return ret;
|
||
|
}
|
||
|
|
||
|
/* NOTREACHED */
|
||
|
} /* --- End of special case --- */
|
||
|
|
||
|
/* Find the number of occurences 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);
|
||
|
if (!buff) {
|
||
|
free_array(ret);
|
||
|
outofmem(bufflen, "buffer for explode()");
|
||
|
}
|
||
|
|
||
|
put_string(ret->item+num, buff);
|
||
|
|
||
|
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);
|
||
|
if (!buff) {
|
||
|
free_array(ret);
|
||
|
outofmem(len, "last fragment in explode()");
|
||
|
}
|
||
|
put_string(ret->item + num, buff);
|
||
|
|
||
|
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 contatenated into one string. The
|
||
|
* resulting string is returned. The function will return at least
|
||
|
* the empty string "".
|
||
|
*
|
||
|
* Non-string elements are ignore; 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;
|
||
|
|
||
|
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++)
|
||
|
{
|
||
|
if (svp->type == T_STRING) {
|
||
|
size += (mp_int)del_len + mstrsize(svp->u.str);
|
||
|
}
|
||
|
else if (destructed_object_ref(svp))
|
||
|
{
|
||
|
/* While we're here anyway... */
|
||
|
assign_svalue(svp, &const0);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/* Allocate the string; cop out if there's nothing to implode.
|
||
|
*/
|
||
|
if (size <= 0)
|
||
|
return ref_mstring(STR_EMPTY);
|
||
|
|
||
|
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;
|
||
|
|
||
|
/* Look for the first element to add (there is at least one!) */
|
||
|
for (i = arr_size; svp->type != T_STRING; )
|
||
|
{
|
||
|
--i;
|
||
|
svp++;
|
||
|
}
|
||
|
|
||
|
memcpy(p, get_txt(svp->u.str), mstrsize(svp->u.str));
|
||
|
p += mstrsize(svp->u.str);
|
||
|
|
||
|
/* Copy the others if any */
|
||
|
while (--i > 0)
|
||
|
{
|
||
|
svp++;
|
||
|
if (svp->type == T_STRING)
|
||
|
{
|
||
|
memcpy(p, deltxt, del_len);
|
||
|
p += del_len;
|
||
|
memcpy(p, get_txt(svp->u.str), mstrsize(svp->u.str));
|
||
|
p += mstrsize(svp->u.str);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
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_svalue_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)
|
||
|
{
|
||
|
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 svalue_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 (svalue_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 = svalue_cmp(vec->item, vec->item + 1);
|
||
|
if (d < 0)
|
||
|
{
|
||
|
sorted[1] = 0;
|
||
|
sorted[0] = 1;
|
||
|
}
|
||
|
d = svalue_cmp(vec->item + sorted[0], vec->item + 2);
|
||
|
if (d < 0)
|
||
|
{
|
||
|
ptrdiff_t tmp = sorted[2];
|
||
|
sorted[2] = sorted[0];
|
||
|
sorted[0] = tmp;
|
||
|
}
|
||
|
d = svalue_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 (svalue_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 ( svalue_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] || svalue_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 svalue_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 svalue_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 && !mstr_tabled(key->u.str))
|
||
|
{
|
||
|
shared_string_key.type = T_STRING;
|
||
|
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 = svalue_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 = svalue_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 (!svalue_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 (!svalue_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 = svalue_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 = svalue_eq(test_val, vec1->item + *index1);
|
||
|
}
|
||
|
while (len1 != 0 && d == 0);
|
||
|
|
||
|
do {
|
||
|
flag2[*index2] = MY_TRUE;
|
||
|
index2++;
|
||
|
len2--;
|
||
|
if (len2 != 0)
|
||
|
d = svalue_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_svalue_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);
|
||
|
return shrink_array(vec1, 0);
|
||
|
/* Fancy way of creating an empty array */
|
||
|
}
|
||
|
|
||
|
/* 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 svalue_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 && !mstr_tabled(svp->u.str))
|
||
|
return MY_FALSE;
|
||
|
if (svalue_cmp(svp, svp+1) > 0)
|
||
|
return MY_FALSE;
|
||
|
}
|
||
|
if (svp->type == T_STRING && !mstr_tabled(svp->u.str))
|
||
|
return MY_FALSE;
|
||
|
|
||
|
return MY_TRUE;
|
||
|
} /* is_ordered() */
|
||
|
|
||
|
/*=========================================================================*/
|
||
|
|
||
|
/* EFUNS */
|
||
|
|
||
|
/*-------------------------------------------------------------------------*/
|
||
|
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.
|
||
|
*/
|
||
|
|
||
|
{
|
||
|
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;
|
||
|
|
||
|
/* If the initialisation value is a mapping, remove all
|
||
|
* destructed elements so that we can use copy_mapping()
|
||
|
* later on.
|
||
|
*/
|
||
|
if (sp->type == T_MAPPING)
|
||
|
check_map_for_destr(sp->u.map);
|
||
|
|
||
|
v = allocate_uninit_array(new_size);
|
||
|
for (svp = v->item, i = 0; i < new_size; i++, svp++)
|
||
|
copy_svalue_no_free(svp, 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't handle either of them).
|
||
|
*/
|
||
|
v = allocate_array(0);
|
||
|
}
|
||
|
else if (argp->type == T_POINTER)
|
||
|
{
|
||
|
svalue_t *svp;
|
||
|
size_t dim, num_dim;
|
||
|
size_t count;
|
||
|
Bool hasInitValue = MY_FALSE;
|
||
|
size_t * curpos = alloca(VEC_SIZE(argp->u.vec) * sizeof(*curpos));
|
||
|
size_t * sizes = alloca(VEC_SIZE(argp->u.vec) * sizeof(*sizes));
|
||
|
vector_t ** curvec = alloca(VEC_SIZE(argp->u.vec) * sizeof(*curvec));
|
||
|
|
||
|
num_dim = VEC_SIZE(argp->u.vec);
|
||
|
|
||
|
if (!curpos || !curvec || !sizes)
|
||
|
{
|
||
|
errorf("Out of stack memory.\n");
|
||
|
/* NOTREACHED */
|
||
|
}
|
||
|
|
||
|
if (num_arg == 2 && (sp->type != T_NUMBER || sp->u.number != 0))
|
||
|
{
|
||
|
hasInitValue = MY_TRUE;
|
||
|
|
||
|
/* If the initialisation value is a mapping, remove all
|
||
|
* destructed elements so that we can use copy_mapping()
|
||
|
* later on.
|
||
|
*/
|
||
|
if (sp->type == T_MAPPING)
|
||
|
check_map_for_destr(sp->u.map);
|
||
|
}
|
||
|
|
||
|
/* 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 < num_dim
|
||
|
; dim++, svp++
|
||
|
)
|
||
|
{
|
||
|
p_int size;
|
||
|
|
||
|
if (svp->type != T_NUMBER)
|
||
|
{
|
||
|
errorf("Bad argument to allocate(): size[%d] is a '%s', "
|
||
|
"expected 'int'.\n"
|
||
|
, (int)dim, typename(svp->type));
|
||
|
/* NOTREACHED */
|
||
|
}
|
||
|
|
||
|
size = svp->u.number;
|
||
|
|
||
|
if (size < 0 || (max_array_size && (size_t)size > max_array_size))
|
||
|
errorf("Illegal array size: %ld\n", (long)size);
|
||
|
|
||
|
if (size == 0 && dim < 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);
|
||
|
|
||
|
sizes[dim] = (size_t)size;
|
||
|
curvec[dim] = NULL;
|
||
|
}
|
||
|
|
||
|
/* Now loop over the dimensions, creating the array structure */
|
||
|
dim = 0;
|
||
|
curpos[0] = 0;
|
||
|
while (dim > 0 || curpos[0] < sizes[0])
|
||
|
{
|
||
|
if (!curvec[dim])
|
||
|
{
|
||
|
/* We just entered this dimension.
|
||
|
* Create a new array and initialise the loop.
|
||
|
*/
|
||
|
if (hasInitValue || dim+1 < num_dim)
|
||
|
{
|
||
|
curvec[dim] = allocate_uninit_array(sizes[dim]);
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
curvec[dim] = allocate_array(sizes[dim]);
|
||
|
/* This is the last dimension, and there is nothing
|
||
|
* to initialize: return immediately to the higher level
|
||
|
*/
|
||
|
curpos[dim] = sizes[dim]; /* In case dim == 0 */
|
||
|
if (dim > 0)
|
||
|
dim--;
|
||
|
continue;
|
||
|
}
|
||
|
curpos[dim] = 0;
|
||
|
}
|
||
|
|
||
|
/* curvec[dim] is valid, and we have to put the next
|
||
|
* element in at index curpos[dim].
|
||
|
*/
|
||
|
if (dim == num_dim-1)
|
||
|
{
|
||
|
/* Last dimension: assign the init value */
|
||
|
if (hasInitValue && curpos[dim] < sizes[dim])
|
||
|
copy_svalue_no_free(curvec[dim]->item+curpos[dim], sp);
|
||
|
}
|
||
|
else if (!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 (curpos[dim] < sizes[dim])
|
||
|
{
|
||
|
/* We got a vector from a lower lever */
|
||
|
put_array(curvec[dim]->item+curpos[dim], curvec[dim+1]);
|
||
|
curvec[dim+1] = NULL;
|
||
|
}
|
||
|
|
||
|
/* Continue to the next element. If we are at the end
|
||
|
* of this dimension, return to the next higher one.
|
||
|
*/
|
||
|
curpos[dim]++;
|
||
|
if (curpos[dim] >= sizes[dim] && dim > 0)
|
||
|
{
|
||
|
dim--;
|
||
|
}
|
||
|
} /* while() */
|
||
|
|
||
|
/* The final vector is now in curvec[0] */
|
||
|
v = curvec[0];
|
||
|
}
|
||
|
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 (current_object->flags & O_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 (!callback_object(&cb))
|
||
|
{
|
||
|
inter_sp = sp;
|
||
|
errorf("object used by filter(array) destructed");
|
||
|
}
|
||
|
|
||
|
push_svalue(w++);
|
||
|
|
||
|
v = apply_callback(&cb, 1);
|
||
|
if (!v || (v->type == T_NUMBER && !v->u.number) )
|
||
|
continue;
|
||
|
|
||
|
flags[cnt] = 1;
|
||
|
res++;
|
||
|
}
|
||
|
|
||
|
free_callback(&cb);
|
||
|
}
|
||
|
|
||
|
/* 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_svalue_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)
|
||
|
*
|
||
|
* 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]
|
||
|
*
|
||
|
* In the mapping case, if <map>[elem] does not exist, the original
|
||
|
* value is returned in the result.
|
||
|
*
|
||
|
* <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;
|
||
|
|
||
|
if (num_arg > 2) {
|
||
|
inter_sp = sp;
|
||
|
errorf("Too many arguments to map(array)\n");
|
||
|
}
|
||
|
m = arg[1].u.map;
|
||
|
|
||
|
res = allocate_array(cnt);
|
||
|
if (!res)
|
||
|
errorf("(map_array) Out of memory: array[%ld] 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_svalue_no_free(x, w);
|
||
|
else
|
||
|
assign_svalue_no_free(x, v);
|
||
|
}
|
||
|
|
||
|
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[%ld] 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 (current_object->flags & O_DESTRUCTED)
|
||
|
continue;
|
||
|
|
||
|
if (destructed_object_ref(w))
|
||
|
assign_svalue(w, &const0);
|
||
|
|
||
|
if (!callback_object(&cb))
|
||
|
errorf("object used by map(array) destructed");
|
||
|
|
||
|
push_svalue(w);
|
||
|
|
||
|
v = apply_callback(&cb, 1);
|
||
|
if (v)
|
||
|
{
|
||
|
transfer_svalue_no_free(x, v);
|
||
|
v->type = T_INVALID;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
free_callback(&cb);
|
||
|
}
|
||
|
|
||
|
/* 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;
|
||
|
callback_t cb;
|
||
|
int error_index;
|
||
|
mp_int step, halfstep, size;
|
||
|
int i, j, index1, index2, end1, end2;
|
||
|
svalue_t *source, *dest, *temp;
|
||
|
|
||
|
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;
|
||
|
|
||
|
/* Get the array. Since the sort sorts in-place, we have
|
||
|
* to make a shallow copy of arrays with more than one
|
||
|
* ref.
|
||
|
*/
|
||
|
data = arg->u.vec;
|
||
|
check_for_destr(data);
|
||
|
|
||
|
if (data->ref != 1)
|
||
|
{
|
||
|
vector_t *vcopy;
|
||
|
|
||
|
vcopy = slice_array(data, 0, VEC_SIZE(data)-1);
|
||
|
free_array(data);
|
||
|
data = vcopy;
|
||
|
arg->u.vec = data;
|
||
|
}
|
||
|
|
||
|
size = (mp_int)VEC_SIZE(data);
|
||
|
|
||
|
/* Easiest case: nothing to sort */
|
||
|
if (size <= 1)
|
||
|
{
|
||
|
free_callback(&cb);
|
||
|
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.
|
||
|
*/
|
||
|
|
||
|
temp = data->item;
|
||
|
|
||
|
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] = temp[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 (!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;
|
||
|
}
|
||
|
|
||
|
temp = data->item;
|
||
|
for (i = size; --i >= 0; )
|
||
|
temp[i] = source[i];
|
||
|
|
||
|
free_callback(&cb);
|
||
|
return arg;
|
||
|
} /* v_sort_array() */
|
||
|
|
||
|
/*-------------------------------------------------------------------------*/
|
||
|
svalue_t *
|
||
|
v_filter_objects (svalue_t *sp, int num_arg)
|
||
|
|
||
|
/* EFUN filter_objects()
|
||
|
*
|
||
|
* object *filter_objects (object *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 */
|
||
|
object_t *ob; /* Object to call */
|
||
|
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++) {
|
||
|
flags[cnt] = MY_FALSE;
|
||
|
v = &p->item[cnt];
|
||
|
|
||
|
/* 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->type != T_OBJECT)
|
||
|
{
|
||
|
if (v->type != T_STRING)
|
||
|
continue;
|
||
|
if ( !(ob = get_object(v->u.str)) )
|
||
|
continue;
|
||
|
} else {
|
||
|
ob = v->u.ob;
|
||
|
if (ob->flags & O_DESTRUCTED)
|
||
|
{
|
||
|
assign_svalue(v, &const0);
|
||
|
continue;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/* Abort the efun if this_object is destructed (slightly
|
||
|
* strange place to check for it).
|
||
|
*/
|
||
|
if (current_object->flags & O_DESTRUCTED)
|
||
|
continue;
|
||
|
|
||
|
/* Call the filter lfun and record the result. */
|
||
|
push_svalue_block(num_arg, arguments);
|
||
|
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])
|
||
|
{
|
||
|
svalue_t sv;
|
||
|
|
||
|
/* Copy the element and update the ref-count */
|
||
|
|
||
|
*--v = sv = p->item[cnt];
|
||
|
if (sv.type == T_STRING)
|
||
|
{
|
||
|
(void)ref_mstring(sv.u.str);
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
(void)ref_object(sv.u.ob, "filter");
|
||
|
}
|
||
|
|
||
|
/* 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 *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 */
|
||
|
object_t *ob; /* Object to call */
|
||
|
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++) {
|
||
|
|
||
|
/* 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->type != T_OBJECT) {
|
||
|
if (v->type != T_STRING)
|
||
|
continue;
|
||
|
if ( !(ob = get_object(v->u.str)) )
|
||
|
continue;
|
||
|
} else {
|
||
|
ob = v->u.ob;
|
||
|
if (ob->flags & O_DESTRUCTED) {
|
||
|
assign_svalue(v, &const0);
|
||
|
continue;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/* Abort the efun if this_object is destructed (slightly
|
||
|
* strange place to check for it).
|
||
|
*/
|
||
|
if (current_object->flags & O_DESTRUCTED)
|
||
|
continue;
|
||
|
|
||
|
/* Call the lfun and record the result */
|
||
|
push_svalue_block(num_arg, arguments);
|
||
|
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 *v; /* Input vector */
|
||
|
vector_t *w; /* Result vector */
|
||
|
mp_int a; /* size of <v> */
|
||
|
mp_int b; /* size of <v>[ix] for all ix */
|
||
|
mp_int i, j;
|
||
|
int no_copy;
|
||
|
/* 1 if <v> has only one ref, else 0. Not just a boolean, it
|
||
|
* is compared with the ref counts of the subvectors of v.
|
||
|
*/
|
||
|
svalue_t *x, *y, *z;
|
||
|
int o;
|
||
|
|
||
|
/* Get and test the arguments */
|
||
|
v = sp->u.vec;
|
||
|
|
||
|
if ( !(a = (mp_int)VEC_SIZE(v)) )
|
||
|
return sp;
|
||
|
|
||
|
/* Find the widest subarray in the main array */
|
||
|
b = 0;
|
||
|
for (x = v->item, i = a; i > 0; i--, x++)
|
||
|
{
|
||
|
mp_int c;
|
||
|
|
||
|
if (x->type != T_POINTER)
|
||
|
{
|
||
|
errorf("Bad arg 1 to transpose_array(): not an array of arrays.\n");
|
||
|
/* NOTREACHED */
|
||
|
return sp;
|
||
|
}
|
||
|
c = (mp_int)VEC_SIZE(x->u.vec);
|
||
|
if (c > b)
|
||
|
b = c;
|
||
|
}
|
||
|
|
||
|
/* If all subarrays are empty, just return an empty array */
|
||
|
if (!b)
|
||
|
{
|
||
|
sp->u.vec = ref_array(v->item->u.vec);
|
||
|
free_array(v);
|
||
|
return sp;
|
||
|
}
|
||
|
|
||
|
no_copy = (v->ref == 1) ? 1 : 0;
|
||
|
|
||
|
/* Allocate and initialize the result vector */
|
||
|
w = allocate_uninit_array(b);
|
||
|
for (j = b, x = w->item; --j >= 0; x++)
|
||
|
{
|
||
|
put_array(x, allocate_array(a));
|
||
|
}
|
||
|
|
||
|
o = offsetof(vector_t, item);
|
||
|
|
||
|
for (i = a, y = v->item; --i >= 0; o += sizeof(svalue_t), y++)
|
||
|
{
|
||
|
mp_int c;
|
||
|
|
||
|
x = w->item;
|
||
|
if (y->type != T_POINTER)
|
||
|
break;
|
||
|
|
||
|
z = y->u.vec->item;
|
||
|
|
||
|
c = b;
|
||
|
if (VEC_SIZE(y->u.vec) < b
|
||
|
&& !(c = (mp_int)VEC_SIZE(y->u.vec)) )
|
||
|
continue;
|
||
|
|
||
|
if (y->u.vec->ref == no_copy)
|
||
|
{
|
||
|
/* Move the values to the result vector */
|
||
|
|
||
|
j = c;
|
||
|
do {
|
||
|
transfer_svalue_no_free(
|
||
|
(svalue_t *)((char*)x->u.vec+o),
|
||
|
z
|
||
|
);
|
||
|
x++;
|
||
|
z++;
|
||
|
} while (--j > 0);
|
||
|
free_empty_vector(y->u.vec);
|
||
|
y->type = T_INVALID;
|
||
|
}
|
||
|
else
|
||
|
{
|
||
|
/* Assign the values to the result vector */
|
||
|
|
||
|
j = c;
|
||
|
do {
|
||
|
assign_svalue_no_free(
|
||
|
(svalue_t *)((char*)x->u.vec+o),
|
||
|
z
|
||
|
);
|
||
|
x++;
|
||
|
z++;
|
||
|
} while (--j > 0);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
/* Clean up and return the result */
|
||
|
|
||
|
free_array(sp->u.vec);
|
||
|
sp->u.vec = w;
|
||
|
return sp;
|
||
|
} /* f_transpose_array() */
|
||
|
|
||
|
/*=========================================================================*/
|
||
|
|
||
|
/* EFUN unique_array()
|
||
|
*
|
||
|
* mixed *unique_array (object *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_OBJECT && arg2->type == T_OBJECT) {
|
||
|
return arg1->u.ob == arg2->u.ob;
|
||
|
} 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 {
|
||
|
svalue_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 (svalue_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++)
|
||
|
{
|
||
|
if (current_object->flags & O_DESTRUCTED)
|
||
|
break;
|
||
|
/* Don't call the filters anymore */
|
||
|
|
||
|
if (arr->item[cnt].type == T_OBJECT
|
||
|
&& !destructed_object_ref(&(arr->item[cnt]))
|
||
|
)
|
||
|
{
|
||
|
/* 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, arr->item[cnt].u.ob);
|
||
|
else
|
||
|
push_ref_object(inter_sp, arr->item[cnt].u.ob, "unique_array");
|
||
|
|
||
|
v = apply_callback(cb, cb->is_lambda ? 1 : 0);
|
||
|
if (v && !sameval(v, skipnum))
|
||
|
ant = put_in(pool, &head, v, &(arr->item[cnt]));
|
||
|
}
|
||
|
}
|
||
|
|
||
|
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()
|
||
|
*
|
||
|
* mixed unique_array(object *obarr, string|closure fun)
|
||
|
* mixed unique_array(object *obarr, string|closure fun, mixed skip)
|
||
|
* mixed unique_array(object *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;
|
||
|
callback_t cb; /* must persist until the end of the function */
|
||
|
|
||
|
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;
|
||
|
|
||
|
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() */
|
||
|
|
||
|
/***************************************************************************/
|
||
|
|