# include "dgd.h" # include "str.h" # include "array.h" # include "object.h" # include "xfloat.h" # include "interpret.h" # include "data.h" # define ARR_CHUNK 128 typedef struct _arrchunk_ { array a[ARR_CHUNK]; /* chunk of arrays */ struct _arrchunk_ *next; /* next in list */ } arrchunk; typedef struct _arrh_ { struct _arrh_ *next; /* next in hash table chain */ array *arr; /* array entry */ uindex index; /* building index */ struct _arrh_ **link; /* next in list */ } arrh; typedef struct _arrhchunk_ { arrh ah[ARR_CHUNK]; /* chunk of arrh entries */ struct _arrhchunk_ *next; /* next in list */ } arrhchunk; # define MELT_CHUNK 128 typedef struct _mapelt_ { unsigned short hashval; /* hash value of index */ value idx; /* index */ value val; /* value */ struct _mapelt_ *next; /* next in hash table */ } mapelt; typedef struct _meltchunk_ { mapelt e[MELT_CHUNK]; /* chunk of mapelt entries */ struct _meltchunk_ *next; /* next in list */ } meltchunk; typedef struct _maphash_ { unsigned short size; /* # elements in hash table */ unsigned short tablesize; /* actual hash table size */ mapelt *table[1]; /* hash table */ } maphash; # define MTABLE_SIZE 16 /* most mappings are quite small */ static unsigned long max_size; /* max. size of array and mapping */ static Uint tag; /* current array tag */ static arrchunk *aclist; /* linked list of all array chunks */ static int achunksz; /* size of current array chunk */ static array *flist; /* free array list */ static arrh **ht; /* array merge table */ static arrh **alink; /* linked list of merged arrays */ static arrhchunk *ahlist; /* linked list of all arrh chunks */ static int ahchunksz; /* size of current arrh chunk */ static mapelt *fmelt; /* free mapelt list */ static meltchunk *meltlist; /* linked list of all mapelt chunks */ static int meltchunksz; /* size of current mapelt chunk */ static uindex idx; /* current building index */ /* * NAME: array->init() * DESCRIPTION: initialize array handling */ void arr_init(size) unsigned int size; { max_size = size; tag = 0; ht = ALLOC(arrh*, ARRMERGETABSZ); memset(ht, '\0', ARRMERGETABSZ * sizeof(arrh *)); achunksz = ARR_CHUNK; ahchunksz = ARR_CHUNK; meltchunksz = MELT_CHUNK; } /* * NAME: array->alloc() * DESCRIPTION: create a new array */ array *arr_alloc(size) unsigned int size; { register array *a; if (flist != (array *) NULL) { /* from free list */ a = flist; flist = (array *) a->primary; } else { if (achunksz == ARR_CHUNK) { register arrchunk *l; /* new chunk */ l = ALLOC(arrchunk, 1); l->next = aclist; aclist = l; achunksz = 0; } a = &aclist->a[achunksz++]; } a->size = size; a->elts = (value *) NULL; a->ref = 0; a->odcount = 0; /* if swapped in, check objects */ a->hashed = (maphash *) NULL; /* only used for mappings */ return a; } /* * NAME: array->new() * DESCRIPTION: create a new array */ array *arr_new(data, size) dataspace *data; register long size; { register array *a; if (size > max_size) { error("Array too large"); } a = arr_alloc((unsigned short) size); if (size > 0) { a->elts = ALLOC(value, size); } a->tag = tag++; a->odcount = odcount; a->primary = &data->alocal; return a; } /* * NAME: array->del() * DESCRIPTION: remove a reference from an array or mapping. If none are * left, the array/mapping is removed. */ void arr_del(a) register array *a; { if (--(a->ref) == 0) { register value *v; register unsigned short i; if (a->primary->arr != (array *) NULL) { d_del_array(a); a->primary->arr = (array *) NULL; } if ((v=a->elts) != (value *) NULL) { for (i = a->size; i > 0; --i) { i_del_value(v++); } FREE(a->elts); } if (a->hashed != (maphash *) NULL) { register mapelt *e, *n, **t; /* * delete the hashtable of a mapping */ for (i = a->hashed->size, t = a->hashed->table; i > 0; t++) { for (e = *t; e != (mapelt *) NULL; e = n) { i_del_value(&e->idx); i_del_value(&e->val); n = e->next; e->next = fmelt; fmelt = e; --i; } } FREE(a->hashed); } a->primary = (arrref *) flist; flist = a; } } /* * NAME: array->freeall() * DESCRIPTION: free all array chunks and mapping element chunks */ void arr_freeall() { # ifdef DEBUG register arrchunk *ac; register meltchunk *mc; /* free array chunks */ for (ac = aclist; ac != (arrchunk *) NULL; ) { register arrchunk *f; f = ac; ac = ac->next; FREE(f); } # endif aclist = (arrchunk *) NULL; achunksz = ARR_CHUNK; flist = (array *) NULL; # ifdef DEBUG /* free mapping element chunks */ for (mc = meltlist; mc != (meltchunk *) NULL; ) { register meltchunk *f; f = mc; mc = mc->next; FREE(f); } # endif meltlist = (meltchunk *) NULL; meltchunksz = MELT_CHUNK; fmelt = (mapelt *) NULL; } /* * NAME: array->put() * DESCRIPTION: Put an array in the merge table, and return its "index". */ uindex arr_put(a) register array *a; { register arrh **h; for (h = &ht[(unsigned long) a % ARRMERGETABSZ]; *h != (arrh *) NULL; h = &(*h)->next) { if ((*h)->arr == a) { return (*h)->index; } } /* * Add a new entry to the hash table. */ if (ahchunksz == ARR_CHUNK) { register arrhchunk *l; l = ALLOC(arrhchunk, 1); l->next = ahlist; ahlist = l; ahchunksz = 0; } *h = &ahlist->ah[ahchunksz++]; (*h)->next = (arrh *) NULL; arr_ref((*h)->arr = a); (*h)->index = idx; (*h)->link = alink; alink = h; return idx++; } /* * NAME: array->clear() * DESCRIPTION: clear the array merge table */ void arr_clear() { register arrh **h; register arrhchunk *l; /* clear hash table */ for (h = alink; h != (arrh **) NULL; ) { register arrh *f; f = *h; *h = (arrh *) NULL; arr_del(f->arr); h = f->link; } alink = (arrh **) NULL; idx = 0; /* free array hash chunks */ for (l = ahlist; l != (arrhchunk *) NULL; ) { register arrhchunk *f; f = l; l = l->next; FREE(f); } ahlist = (arrhchunk *) NULL; ahchunksz = ARR_CHUNK; } /* * NAME: copytmp() * DESCRIPTION: make temporary copies of values */ static void copytmp(v1, a) register value *v1; register array *a; { register value *v2; register unsigned short n; v2 = d_get_elts(a); if (a->odcount == odcount) { /* * no need to check for destructed objects */ memcpy(v1, v2, a->size * sizeof(value)); } else { /* * Copy and check for destructed objects. If destructed objects are * found, they will be replaced by 0 in the original array. */ a->odcount = odcount; for (n = a->size; n != 0; --n) { if (v2->type == T_OBJECT && DESTRUCTED(v2)) { *v2 = zero_value; } *v1++ = *v2++; } } } /* * NAME: array->copy() * DESCRIPTION: copy the elements of an array or mapping */ static void arr_copy(v, a) value *v; array *a; { i_copy(v, d_get_elts(a), a->size); a->odcount = odcount; } /* * NAME: array->add() * DESCRIPTION: add two arrays */ array *arr_add(data, a1, a2) dataspace *data; register array *a1, *a2; { register array *a; a = arr_new(data, (long) a1->size + a2->size); arr_copy(a->elts, a1); arr_copy(a->elts + a1->size, a2); d_ref_imports(a); return a; } static int cmp P((cvoid*, cvoid*)); /* * NAME: cmp() * DESCRIPTION: compare two values */ static int cmp(cv1, cv2) cvoid *cv1, *cv2; { register value *v1, *v2; register int i; xfloat f1, f2; v1 = (value *) cv1; v2 = (value *) cv2; i = v1->type - v2->type; if (i != 0) { return i; /* order by type */ } switch (v1->type) { case T_INT: return (v1->u.number <= v2->u.number) ? (v1->u.number < v2->u.number) ? -1 : 0 : 1; case T_FLOAT: VFLT_GET(v1, f1); VFLT_GET(v2, f2); return flt_cmp(&f1, &f2); case T_STRING: return str_cmp(v1->u.string, v2->u.string); case T_OBJECT: return (v1->oindex <= v2->oindex) ? (v1->oindex < v2->oindex) ? -1 : 0 : 1; case T_ARRAY: case T_MAPPING: return (v1->u.array->tag <= v2->u.array->tag) ? (v1->u.array->tag < v2->u.array->tag) ? -1 : 0 : 1; } } /* * NAME: search() * DESCRIPTION: search for a value in an array */ static int search(v1, v2, h, step, place) register value *v1, *v2; register unsigned short h; register int step; /* 1 for arrays, 2 for mappings */ bool place; { register unsigned short l, m; register Int c; register value *v3; register unsigned short mask; mask = -step; l = 0; while (l < h) { m = ((l + h) >> 1) & mask; v3 = v2 + m; c = cmp(v1, v3); if (c == 0) { if (T_INDEXED(v1->type) && v1->u.array != v3->u.array) { /* * It is possible for one object to export an array, both * objects being swapped out after that, and the other object * exporting the array back again. This gives two arrays with * identical tags, which do not point to the same actual values * and are not guaranteed to contain the same values, either. * A possible way out is to give new tags to imported arrays * and to resort all mappings before swapping them out. * The solution used here is to check every array with this tag, * and hope this kind of thing doesn't occur too often... */ /* search forward */ for (;;) { m += step; v3 += step; if (m == h || !T_INDEXED(v3->type)) { break; /* out of range */ } if (v1->u.array == v3->u.array) { return m; /* found the right one */ } if (v1->u.array->tag != v3->u.array->tag) { break; /* wrong tag */ } } /* search backward */ m = ((l + h) >> 1) & mask; v3 = v2 + m; for (;;) { v3 -= step; if (m == l || !T_INDEXED(v3->type)) { break; /* out of range */ } m -= step; if (v1->u.array == v3->u.array) { return m; /* found the right one */ } if (v1->u.array->tag != v3->u.array->tag) { break; /* wrong tag */ } } break; /* not found */ } return m; /* found */ } else if (c < 0) { h = m; /* search in lower half */ } else { l = m + step; /* search in upper half */ } } /* * not found */ return (place) ? l : -1; } /* * NAME: array->sub() * DESCRIPTION: subtract one array from another */ array *arr_sub(data, a1, a2) dataspace *data; array *a1, *a2; { register value *v1, *v2, *v3; register array *a3; register unsigned short n, size; if (a2->size == 0) { /* * array - ({ }) * Return a copy of the first array. */ a3 = arr_new(data, (long) a1->size); arr_copy(a3->elts, a1); d_ref_imports(a3); return a3; } /* create new array */ a3 = arr_new(data, (long) a1->size); if (a3->size == 0) { /* subtract from empty array */ return a3; } size = a2->size; /* copy and sort values of subtrahend */ copytmp(v2 = ALLOCA(value, size), a2); qsort(v2, size, sizeof(value), cmp); v1 = d_get_elts(a1); v3 = a3->elts; if (a1->odcount == odcount) { for (n = a1->size; n > 0; --n) { if (search(v1, v2, size, 1, FALSE) < 0) { /* * not found in subtrahend: copy to result array */ i_ref_value(v1); *v3++ = *v1; } v1++; } } else { a1->odcount = odcount; for (n = a1->size; n > 0; --n) { if (v1->type == T_OBJECT && DESTRUCTED(v1)) { /* replace destructed object by 0 */ *v1 = zero_value; } if (search(v1, v2, size, 1, FALSE) < 0) { /* * not found in subtrahend: copy to result array */ i_ref_value(v1); *v3++ = *v1; } v1++; } } AFREE(v2); /* free copy of values of subtrahend */ a3->size = v3 - a3->elts; if (a3->size == 0) { FREE(a3->elts); a3->elts = (value *) NULL; } d_ref_imports(a3); return a3; } /* * NAME: array->intersect() * DESCRIPTION: A - (A - B). If A and B are sets, the result is a set also. */ array *arr_intersect(data, a1, a2) dataspace *data; array *a1, *a2; { register value *v1, *v2, *v3; register array *a3; register unsigned short n, size; if (a1->size == 0 || a2->size == 0) { /* array & ({ }) */ return arr_new(data, 0L); } /* create new array */ a3 = arr_new(data, (long) a1->size); size = a2->size; /* copy and sort values of 2nd array */ copytmp(v2 = ALLOCA(value, size), a2); qsort(v2, size, sizeof(value), cmp); v1 = d_get_elts(a1); v3 = a3->elts; if (a1->odcount == odcount) { for (n = a1->size; n > 0; --n) { if (search(v1, v2, a2->size, 1, FALSE) >= 0) { /* * element is in both arrays: copy to result array */ i_ref_value(v1); *v3++ = *v1; } v1++; } } else { a1->odcount = odcount; for (n = a1->size; n > 0; --n) { if (v1->type == T_OBJECT && DESTRUCTED(v1)) { /* replace destructed object by 0 */ *v1 = zero_value; } if (search(v1, v2, a2->size, 1, FALSE) >= 0) { /* * element is in both arrays: copy to result array */ i_ref_value(v1); *v3++ = *v1; } v1++; } } AFREE(v2); /* free copy of values of 2nd array */ a3->size = v3 - a3->elts; if (a3->size == 0) { FREE(a3->elts); a3->elts = (value *) NULL; } d_ref_imports(a3); return a3; } /* * NAME: array->setadd() * DESCRIPTION: A + (B - A). If A and B are sets, the result is a set also. */ array *arr_setadd(data, a1, a2) dataspace *data; array *a1, *a2; { register value *v, *v1, *v2; value *v3; register array *a3; register unsigned short n, size; if (a1->size == 0) { /* ({ }) | array */ a3 = arr_new(data, (long) a2->size); arr_copy(a3->elts, a2); d_ref_imports(a3); return a3; } if (a2->size == 0) { /* array | ({ }) */ a3 = arr_new(data, (long) a1->size); arr_copy(a3->elts, a1); d_ref_imports(a3); return a3; } /* make room for elements to add */ v3 = ALLOCA(value, a2->size); /* copy and sort values of 1st array */ copytmp(v1 = ALLOCA(value, size = a1->size), a1); qsort(v1, size, sizeof(value), cmp); v = v3; v2 = d_get_elts(a2); if (a2->odcount == odcount) { for (n = a2->size; n > 0; --n) { if (search(v2, v1, size, 1, FALSE) < 0) { /* * element is only in second array: copy to result array */ *v++ = *v2; } v2++; } } else { a2->odcount = odcount; for (n = a2->size; n > 0; --n) { if (v2->type == T_OBJECT && DESTRUCTED(v2)) { /* replace destructed object by 0 */ *v2 = zero_value; } if (search(v2, v1, size, 1, FALSE) < 0) { /* * element is only in second array: copy to result array */ *v++ = *v2; } v2++; } } AFREE(v1); /* free copy of values of 1st array */ n = v - v3; if ((long) size + n > max_size) { AFREE(v3); error("Array too large"); } a3 = arr_new(data, (long) size + n); i_copy(a3->elts, a1->elts, size); i_copy(a3->elts + size, v3, n); AFREE(v3); d_ref_imports(a3); return a3; } /* * NAME: array->setxadd() * DESCRIPTION: (A - B) + (B - A). If A and B are sets, the result is a set * also. */ array *arr_setxadd(data, a1, a2) dataspace *data; array *a1, *a2; { register value *v, *w, *v1, *v2; value *v3; register array *a3; register unsigned short n, size; unsigned short num; if (a1->size == 0) { /* ({ }) ^ array */ a3 = arr_new(data, (long) a2->size); arr_copy(a3->elts, a2); d_ref_imports(a3); return a3; } if (a2->size == 0) { /* array ^ ({ }) */ a3 = arr_new(data, (long) a1->size); arr_copy(a3->elts, a1); d_ref_imports(a3); return a3; } /* copy values of 1st array */ copytmp(v1 = ALLOCA(value, size = a1->size), a1); /* copy and sort values of 2nd array */ copytmp(v2 = ALLOCA(value, size = a2->size), a2); qsort(v2, size, sizeof(value), cmp); /* room for first half of result */ v3 = ALLOCA(value, a1->size); v = v3; w = v1; for (n = a1->size; n > 0; --n) { if (search(v1, v2, size, 1, FALSE) < 0) { /* * element is only in first array: copy to result array */ *v++ = *v1; } else { /* * element is in both: keep it for the next round */ *w++ = *v1; } v1++; } num = v - v3; /* sort copy of 1st array */ v1 -= a1->size; qsort(v1, size = w - v1, sizeof(value), cmp); v = v2; w = a2->elts; for (n = a2->size; n > 0; --n) { if (search(w, v1, size, 1, FALSE) < 0) { /* * element is only in second array: copy to 2nd result array */ *v++ = *w; } w++; } n = v - v2; if ((long) num + n > max_size) { AFREE(v3); AFREE(v2); AFREE(v1); error("Array too large"); } a3 = arr_new(data, (long) num + n); i_copy(a3->elts, v3, num); i_copy(a3->elts + num, v2, n); AFREE(v3); AFREE(v2); AFREE(v1); d_ref_imports(a3); return a3; } /* * NAME: array->index() * DESCRIPTION: index an array */ unsigned short arr_index(a, l) register array *a; register long l; { if (l < 0 || l >= (long) a->size) { error("Array index out of range"); } return l; } /* * NAME: array->ckrange() * DESCRIPTION: check an array subrange */ void arr_ckrange(a, l1, l2) array *a; register long l1, l2; { if (l1 < 0 || l1 > l2 + 1 || l2 >= (long) a->size) { error("Invalid array range"); } } /* * NAME: array->range() * DESCRIPTION: return a subrange of an array */ array *arr_range(data, a, l1, l2) dataspace *data; register array *a; register long l1, l2; { register array *range; if (l1 < 0 || l1 > l2 + 1 || l2 >= (long) a->size) { error("Invalid array range"); } range = arr_new(data, l2 - l1 + 1); i_copy(range->elts, d_get_elts(a) + l1, (unsigned short) (l2 - l1 + 1)); d_ref_imports(range); return range; } static int mapcmp P((cvoid*, cvoid*)); static bool ididx; /* flag for identical indices */ /* * NAME: mapcmp() * DESCRIPTION: compare two mapping indices */ static int mapcmp(cv1, cv2) cvoid *cv1, *cv2; { register int c; register value *v1, *v2; c = cmp(cv1, cv2); v1 = (value *) cv1; v2 = (value *) cv2; if (c == 0 && v1 != v2 && (!T_INDEXED(v1->type) || v1->u.array == v2->u.array)) { /* jumping out of qsort might leave the mapping in a bad state */ ididx = TRUE; } return c; } /* * NAME: mapping->new() * DESCRIPTION: create a new mapping */ array *map_new(data, size) dataspace *data; register long size; { array *m; if (size > max_size << 1) { error("Mapping too large"); } m = arr_alloc((unsigned short) size); if (size > 0) { m->elts = ALLOC(value, size); } m->tag = tag++; m->odcount = odcount; m->primary = &data->alocal; return m; } /* * NAME: mapping->sort() * DESCRIPTION: prune and sort a mapping */ void map_sort(m) register array *m; { register unsigned short i, sz; register value *v, *w; for (i = m->size, sz = 0, v = w = m->elts; i > 0; i -= 2) { if (v[1].type != T_INT || v[1].u.number != 0) { *w++ = *v++; *w++ = *v++; sz += 2; } else { /* delete index and skip zero value */ i_del_value(v); v += 2; } } if (sz != 0) { ididx = FALSE; qsort(m->elts, sz >> 1, 2 * sizeof(value), mapcmp); if (ididx) { error("Identical indices in mapping"); } } else if (m->size > 0) { FREE(m->elts); m->elts = (value *) NULL; } m->size = sz; } /* * NAME: mapping->clean() * DESCRIPTION: remove destructed objects from mapping */ static void map_clean(m) register array *m; { register value *v1, *v2; register unsigned short i, size; if (m->odcount == odcount) { return; /* no destructed objects */ } /* * remove destructed objects in the array */ if (m->size != 0) { size = 0; v1 = v2 = d_get_elts(m); for (i = m->size; i > 0; i -= 2) { if (v2->type == T_OBJECT && DESTRUCTED(v2)) { /* * index is destructed object */ d_assign_elt(m, v2 + 1, &zero_value); v2 += 2; } else if (v2[1].type == T_OBJECT && DESTRUCTED(&v2[1])) { /* * value is destructed object */ d_assign_elt(m, v2, &zero_value); v2 += 2; } else { *v1++ = *v2++; *v1++ = *v2++; size += 2; } } if (size == 0) { FREE(m->elts); m->elts = (value *) NULL; } if (size != m->size) { d_change_map(m); } m->size = size; } /* * remove destructed objects in the hash table */ if (m->hashed != (maphash *) NULL && m->hashed->size != 0) { register mapelt *e, **p, **t; size = 0; t = m->hashed->table; for (i = m->hashed->size; i > 0; ) { for (p = t++; (e=*p) != (mapelt *) NULL; --i) { if (e->idx.type == T_OBJECT && DESTRUCTED(&e->idx)) { /* * index is destructed object */ d_assign_elt(m, &e->val, &zero_value); } else if (e->val.type == T_OBJECT && DESTRUCTED(&e->val)) { /* * value is destructed object */ d_assign_elt(m, &e->idx, &zero_value); } else { size++; p = &e->next; continue; } *p = e->next; e->next = fmelt; fmelt = e; } } m->hashed->size = size; } m->odcount = odcount; /* update */ } /* * NAME: mapping->compact() * DESCRIPTION: compact a mapping: put elements from the hash table into * the array, and remove destructed objects */ void map_compact(m) register array *m; { register value *v1, *v2; register unsigned short i, arrsize, hashsize; if ((m->size == 0 || m->odcount == odcount) && (m->hashed == (maphash *) NULL || m->hashed->size == 0)) { /* skip empty or unchanged mapping */ return; } arrsize = 0; if (m->size > 0) { v1 = v2 = d_get_elts(m); if (m->odcount != odcount) { /* * remove destructed objects in the array */ for (i = m->size; i > 0; i -= 2) { if (v2->type == T_OBJECT && DESTRUCTED(v2)) { /* * index is destructed object */ d_assign_elt(m, v2 + 1, &zero_value); v2 += 2; } else if (v2[1].type == T_OBJECT && DESTRUCTED(&v2[1])) { /* * value is destructed object */ d_assign_elt(m, v2, &zero_value); v2 += 2; } else { *v1++ = *v2++; *v1++ = *v2++; arrsize += 2; } } } else { arrsize = m->size; } } /* * convert hashtable into sorted array */ hashsize = 0; if (m->hashed != (maphash *) NULL) { if (m->hashed->size != 0) { register mapelt *e, *n, **t; v2 = ALLOCA(value, m->hashed->size << 1); t = m->hashed->table; if (m->odcount == odcount) { for (i = m->hashed->size; i > 0; ) { for (e = *t++; e != (mapelt *) NULL; --i, e = n) { *v2++ = e->idx; *v2++ = e->val; n = e->next; e->next = fmelt; fmelt = e; } } hashsize = m->hashed->size << 1; } else { for (i = m->hashed->size; i > 0; ) { for (e = *t++; e != (mapelt *) NULL; --i, e = n) { if (e->idx.type == T_OBJECT && DESTRUCTED(&e->idx)) { /* * index is destructed object */ d_assign_elt(m, &e->val, &zero_value); } else if (e->val.type == T_OBJECT && DESTRUCTED(&e->val)) { /* * value is destructed object */ d_assign_elt(m, &e->idx, &zero_value); } else { /* * copy to array */ *v2++ = e->idx; *v2++ = e->val; hashsize += 2; } n = e->next; e->next = fmelt; fmelt = e; } } } if (hashsize == 0) { AFREE(v2); /* nothing in the hash table */ } else { v2 -= hashsize; qsort(v2, hashsize >> 1, 2 * sizeof(value), cmp); } } FREE(m->hashed); m->hashed = (maphash *) NULL; } m->odcount = odcount; /* update */ if (hashsize > 0) { register value *v3; register unsigned short j; /* * merge the two value arrays */ v1 = m->elts; v3 = ALLOC(value, arrsize + hashsize); for (i = arrsize, j = hashsize; i > 0 && j > 0; ) { if (cmp(v1, v2) <= 0) { *v3++ = *v1++; *v3++ = *v1++; i -= 2; } else { *v3++ = *v2++; *v3++ = *v2++; j -= 2; } } /* * copy tails of arrays */ memcpy(v3, v1, i * sizeof(value)); v3 += i; memcpy(v3, v2, j * sizeof(value)); v3 += j; AFREE(v2 - (hashsize - j)); if (m->size > 0) { FREE(m->elts); } m->size = arrsize + hashsize; m->elts = v3 - m->size; } else if (arrsize != m->size) { /* * destructed objects were removed */ if (arrsize == 0) { FREE(m->elts); m->elts = (value *) NULL; } m->size = arrsize; d_change_map(m); } } /* * NAME: mapping->size() * DESCRIPTION: return the size of a mapping */ unsigned short map_size(m) register array *m; { unsigned short size; map_clean(m); size = m->size >> 1; if (m->hashed != (maphash *) NULL) { size += m->hashed->size; } return size; } /* * NAME: mapping->add() * DESCRIPTION: add two mappings */ array *map_add(data, m1, m2) dataspace *data; array *m1, *m2; { register value *v1, *v2, *v3; register unsigned short n1, n2; register Int c; array *m3; map_compact(m1); map_compact(m2); m3 = map_new(data, (long) m1->size + m2->size); if (m3->size == 0) { /* add two empty mappings */ return m3; } v1 = m1->elts; v2 = m2->elts; v3 = m3->elts; for (n1 = m1->size, n2 = m2->size; n1 > 0 && n2 > 0; ) { c = cmp(v1, v2); if (c < 0) { /* the smaller element is in m1 */ i_copy(v3, v1, 2); v1 += 2; v3 += 2; n1 -= 2; } else { /* the smaller - or overriding - element is in m2 */ i_copy(v3, v2, 2); v2 += 2; v3 += 2; n2 -= 2; if (c == 0) { /* equal elements? */ if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) { register value *v; register unsigned short n; /* * The array tags are the same, but the arrays are not. * Check ahead to see if the array is somewhere else * in m2; if not, copy the element from m1 as well. */ v = v2; n = n2; for (;;) { v += 2; n -= 2; if (n == 0 || !T_INDEXED(v->type) || v->u.array->tag != v1->u.array->tag) { /* not in m2 */ i_copy(v3, v1, 2); v3 += 2; break; } if (v->u.array == v1->u.array) { /* also in m2 */ break; } } } /* skip m1 */ v1 += 2; n1 -= 2; } } } /* copy tail part of m1 */ i_copy(v3, v1, n1); v3 += n1; /* copy tail part of m2 */ i_copy(v3, v2, n2); v3 += n2; m3->size = v3 - m3->elts; if (m3->size == 0) { FREE(m3->elts); m3->elts = (value *) NULL; } d_ref_imports(m3); return m3; } /* * NAME: mapping->sub() * DESCRIPTION: subtract an array from a mapping */ array *map_sub(data, m1, a2) dataspace *data; array *m1, *a2; { register value *v1, *v2, *v3; register unsigned short n1, n2, size; register Int c; array *m3; map_compact(m1); m3 = map_new(data, (long) m1->size); if (m1->size == 0) { /* subtract from empty mapping */ return m3; } if ((size=a2->size) == 0) { /* subtract empty array */ arr_copy(m3->elts, m1); d_ref_imports(m3); return m3; } /* copy and sort values of array */ copytmp(v2 = ALLOCA(value, size), a2); qsort(v2, size, sizeof(value), cmp); v1 = m1->elts; v3 = m3->elts; for (n1 = m1->size, n2 = size; n1 > 0 && n2 > 0; ) { c = cmp(v1, v2); if (c < 0) { /* the smaller element is in m1 */ i_copy(v3, v1, 2); v1 += 2; v3 += 2; n1 -= 2; } else if (c > 0) { /* the smaller element is in a2 */ v2++; --n2; } else { /* equal elements? */ if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) { register value *v; register unsigned short n; /* * The array tags are the same, but the arrays are not. * Check ahead to see if the array is somewhere else * in a2; if not, copy the element from m1. */ v = v2; n = n2; for (;;) { v++; --n; if (n == 0 || !T_INDEXED(v->type) || v->u.array->tag != v1->u.array->tag) { /* not in a2 */ i_copy(v3, v1, 2); v3 += 2; break; } if (v->u.array == v1->u.array) { /* also in a2 */ break; } } } /* skip m1 */ v1 += 2; n1 -= 2; } } AFREE(v2 - (size - n2)); /* copy tail part of m1 */ i_copy(v3, v1, n1); v3 += n1; m3->size = v3 - m3->elts; if (m3->size == 0) { FREE(m3->elts); m3->elts = (value *) NULL; } d_ref_imports(m3); return m3; } /* * NAME: mapping->intersect() * DESCRIPTION: intersect a mapping with an array */ array *map_intersect(data, m1, a2) dataspace *data; array *m1, *a2; { register value *v1, *v2, *v3; register unsigned short n1, n2, size; register Int c; array *m3; map_compact(m1); if ((size=a2->size) == 0) { /* intersect with empty array */ return map_new(data, 0L); } m3 = map_new(data, (long) m1->size); if (m1->size == 0) { /* intersect with empty mapping */ return m3; } /* copy and sort values of array */ copytmp(v2 = ALLOCA(value, size), a2); qsort(v2, size, sizeof(value), cmp); v1 = m1->elts; v3 = m3->elts; for (n1 = m1->size, n2 = size; n1 > 0 && n2 > 0; ) { c = cmp(v1, v2); if (c < 0) { /* the smaller element is in m1 */ v1 += 2; n1 -= 2; } else if (c > 0) { /* the smaller element is in a2 */ v2++; --n2; } else { /* equal elements? */ if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) { register value *v; register unsigned short n; /* * The array tags are the same, but the arrays are not. * Check ahead to see if the array is somewhere else * in a2; if not, don't copy the element from m1. */ v = v2; n = n2; for (;;) { v++; --n; if (n == 0 || !T_INDEXED(v->type) || v->u.array->tag != v1->u.array->tag) { /* not in a2 */ break; } if (v->u.array == v1->u.array) { /* also in a2 */ i_copy(v3, v1, 2); v3 += 2; v1 += 2; n1 -= 2; break; } } } else { /* equal */ i_copy(v3, v1, 2); v3 += 2; v1 += 2; n1 -= 2; } v2++; --n2; } } AFREE(v2 - (size - n2)); m3->size = v3 - m3->elts; if (m3->size == 0) { FREE(m3->elts); m3->elts = (value *) NULL; } d_ref_imports(m3); return m3; } /* * NAME: mapping->grow() * DESCRIPTION: add an element to a mapping */ static mapelt *map_grow(m, hashval) register array *m; unsigned short hashval; { register maphash *h; register mapelt *e; register unsigned short i; h = m->hashed; if ((m->size >> 1) + ((h == (maphash *) NULL) ? 0 : h->size) >= max_size) { map_compact(m); if (m->size >> 1 >= max_size) { error("Mapping too large to grow"); } h = (maphash *) NULL; } if (h == (maphash *) NULL) { /* * add hash table to this mapping */ m->hashed = h = (maphash *) ALLOC(char, sizeof(maphash) + (MTABLE_SIZE - 1) * sizeof(mapelt*)); h->size = 0; h->tablesize = MTABLE_SIZE; memset(h->table, '\0', MTABLE_SIZE * sizeof(mapelt*)); } else if (h->size << 2 >= h->tablesize * 3) { register mapelt *n, **t; register unsigned short j; /* * extend hash table for this mapping */ i = h->tablesize << 1; h = (maphash *) ALLOC(char, sizeof(maphash) + (i - 1) * sizeof(mapelt*)); h->size = m->hashed->size; h->tablesize = i; memset(h->table, '\0', i * sizeof(mapelt*)); /* * copy entries from old hashtable to new hashtable */ for (j = h->size, t = m->hashed->table; j > 0; t++) { for (e = *t; e != (mapelt *) NULL; e = n) { n = e->next; i = e->hashval % h->tablesize; e->next = h->table[i]; h->table[i] = e; --j; } } FREE(m->hashed); m->hashed = h; } h->size++; if (fmelt != (mapelt *) NULL) { /* from free list */ e = fmelt; fmelt = e->next; } else { if (meltchunksz == MELT_CHUNK) { register meltchunk *l; /* new chunk */ l = ALLOC(meltchunk, 1); l->next = meltlist; meltlist = l; meltchunksz = 0; } e = &meltlist->e[meltchunksz++]; } e->hashval = hashval; e->idx = zero_value; e->val = zero_value; i = hashval % h->tablesize; e->next = h->table[i]; h->table[i] = e; return e; } /* * NAME: mapping->index() * DESCRIPTION: Index a mapping with a value. If a third argument is supplied, * perform an assignment; otherwise return the indexed value. */ value *map_index(m, val, elt) register array *m; value *val, *elt; { register unsigned short i; bool del; if (elt != (value *) NULL && elt->type == T_INT && elt->u.number == 0) { elt = (value *) NULL; del = TRUE; } else { del = FALSE; } if (m->size > 0) { register int n; n = search(val, d_get_elts(m), m->size, 2, FALSE); if (n >= 0) { register value *v; /* * found in the array */ v = &m->elts[n]; if (elt != (value *) NULL) { /* * change the element */ if (val->type == T_OBJECT) { v->u.objcnt = val->u.objcnt; /* refresh */ } d_assign_elt(m, v + 1, elt); } else if (del || (val->type == T_OBJECT && val->u.objcnt != v->u.objcnt)) { /* * delete the element */ d_assign_elt(m, v, &zero_value); d_assign_elt(m, v + 1, &zero_value); m->size -= 2; if (m->size == 0) { /* last element removed */ FREE(m->elts); m->elts = (value *) NULL; } else { /* move tail */ memcpy(v, v + 2, (m->size - n) * sizeof(value)); } d_change_map(m); return &zero_value; } return v + 1; } } switch (val->type) { case T_INT: i = val->u.number; break; case T_FLOAT: i = VFLT_HASH(val); break; case T_STRING: i = hashstr(val->u.string->text, STRMAPHASHSZ); break; case T_OBJECT: i = val->oindex; break; case T_ARRAY: case T_MAPPING: i = (unsigned short) ((unsigned long) val->u.array >> 3); break; } if (m->hashed != (maphash *) NULL) { register mapelt *e, **p; for (p = &m->hashed->table[i % m->hashed->tablesize]; (e=*p) != (mapelt *) NULL; p = &e->next) { if (cmp(val, &e->idx) == 0 && (!T_INDEXED(val->type) || val->u.array == e->idx.u.array)) { /* * found in the hashtable */ if (elt != (value *) NULL) { /* * change element */ if (val->type == T_OBJECT) { e->idx.u.objcnt = val->u.objcnt; /* refresh */ } d_assign_elt(m, &e->val, elt); } else if (del || (val->type == T_OBJECT && val->u.objcnt != e->idx.u.objcnt)) { /* * delete element */ d_assign_elt(m, &e->idx, &zero_value); d_assign_elt(m, &e->val, &zero_value); *p = e->next; e->next = fmelt; fmelt = e; m->hashed->size--; return &zero_value; } return &e->val; } } } if (elt != (value *) NULL) { register mapelt *e; /* * extend mapping */ e = map_grow(m, i); d_change_map(m); d_assign_elt(m, &e->idx, val); d_assign_elt(m, &e->val, elt); } /* * not found */ return &zero_value; } /* * NAME: mapping->range() * DESCRIPTION: return a mapping value subrange */ array *map_range(data, m, v1, v2) dataspace *data; array *m; register value *v1, *v2; { register unsigned short from, to; register array *range; map_compact(m); /* determine subrange */ from = (v1 == (value *) NULL) ? 0 : search(v1, m->elts, m->size, 2, TRUE); if (v2 == (value *) NULL) { to = m->size; } else { to = search(v2, m->elts, m->size, 2, TRUE); if (to < m->size && cmp(v2, &m->elts[to]) == 0 && (!T_INDEXED(v2->type) || v2->u.array == m->elts[to].u.array)) { /* * include last element */ to += 2; } } if (from >= to) { return map_new(data, 0L); /* empty subrange */ } /* copy subrange */ range = map_new(data, (long) (to -= from)); i_copy(range->elts, m->elts + from, to); d_ref_imports(range); return range; } /* * NAME: mapping->indices() * DESCRIPTION: return the indices of a mapping */ array *map_indices(data, m) dataspace *data; array *m; { register array *indices; register value *v1, *v2; register unsigned short n; map_compact(m); indices = arr_new(data, (long) (n = m->size >> 1)); v1 = indices->elts; for (v2 = m->elts; n > 0; v2 += 2, --n) { i_ref_value(v2); *v1++ = *v2; } d_ref_imports(indices); return indices; } /* * NAME: mapping->values() * DESCRIPTION: return the values of a mapping */ array *map_values(data, m) dataspace *data; array *m; { register array *values; register value *v1, *v2; register unsigned short n; map_compact(m); values = arr_new(data, (long) (n = m->size >> 1)); v1 = values->elts; for (v2 = m->elts + 1; n > 0; v2 += 2, --n) { i_ref_value(v2); *v1++ = *v2; } d_ref_imports(values); return values; }