|
|
1 # include "dgd.h"
2 # include "str.h"
3 # include "array.h"
4 # include "object.h"
5 # include "xfloat.h"
6 # include "interpret.h"
7 # include "data.h"
8
9 # define ARR_CHUNK 128
10
11 typedef struct _arrchunk_ {
12 struct _arrchunk_ *next; /* next in list */
13 array a[ARR_CHUNK]; /* chunk of arrays */
14 } arrchunk;
15
16 typedef struct _arrh_ {
17 struct _arrh_ *next; /* next in hash table chain */
18 array *arr; /* array entry */
19 Uint index; /* building index */
20 struct _arrh_ **link; /* next in list */
21 } arrh;
22
23 typedef struct _arrhchunk_ {
24 struct _arrhchunk_ *next; /* next in list */
25 arrh ah[ARR_CHUNK]; /* chunk of arrh entries */
26 } arrhchunk;
27
28 # define MELT_CHUNK 128
29
30 typedef struct _mapelt_ {
31 unsigned short hashval; /* hash value of index */
32 value idx; /* index */
33 value val; /* value */
34 struct _mapelt_ *next; /* next in hash table */
35 } mapelt;
36
37 typedef struct _meltchunk_ {
38 struct _meltchunk_ *next; /* next in list */
39 mapelt e[MELT_CHUNK]; /* chunk of mapelt entries */
40 } meltchunk;
41
42 typedef struct _maphash_ {
43 unsigned short size; /* # elements in hash table */
44 unsigned short tablesize; /* actual hash table size */
45 mapelt *table[1]; /* hash table */
46 } maphash;
47
48 # define MTABLE_SIZE 16 /* most mappings are quite small */
49
50 # define ABCHUNKSZ 32
51
52 typedef struct arrbak {
53 array *arr; /* array backed up */
54 unsigned short size; /* original size (of mapping) */
55 value *original; /* original elements */
56 dataplane *plane; /* original dataplane */
57 } arrbak;
58
59 struct _abchunk_ {
60 short chunksz; /* size of this chunk */
61 struct _abchunk_ *next; /* next in linked list */
62 arrbak ab[ABCHUNKSZ]; /* chunk of arrbaks */
63 };
64
65 static unsigned long max_size; /* max. size of array and mapping */
66 static Uint tag; /* current array tag */
67 static arrchunk *aclist; /* linked list of all array chunks */
68 static int achunksz; /* size of current array chunk */
69 static array *flist; /* free array list */
70 static arrh **ht; /* array merge table */
71 static arrh **alink; /* linked list of merged arrays */
72 static arrhchunk *ahlist; /* linked list of all arrh chunks */
73 static int ahchunksz; /* size of current arrh chunk */
74 static mapelt *fmelt; /* free mapelt list */
75 static meltchunk *meltlist; /* linked list of all mapelt chunks */
76 static int meltchunksz; /* size of current mapelt chunk */
77 static Uint idx; /* current building index */
78
79 /*
80 * NAME: array->init()
81 * DESCRIPTION: initialize array handling
82 */
83 void arr_init(size)
84 unsigned int size;
85 {
86 max_size = size;
87 tag = 0;
88 aclist = (arrchunk *) NULL;
89 ahchunksz = ARR_CHUNK;
90 flist = (array *) NULL;
91 ht = ALLOC(arrh*, ARRMERGETABSZ);
92 memset(ht, '\0', ARRMERGETABSZ * sizeof(arrh *));
93 alink = (arrh **) NULL;
94 ahlist = (arrhchunk *) NULL;
95 achunksz = ARR_CHUNK;
96 fmelt = (mapelt *) NULL;
97 meltlist = (meltchunk *) NULL;
98 meltchunksz = MELT_CHUNK;
99 }
100
101 /*
102 * NAME: array->alloc()
103 * DESCRIPTION: create a new array
104 */
105 array *arr_alloc(size)
106 unsigned int size;
107 {
108 register array *a;
109
110 if (flist != (array *) NULL) {
111 /* from free list */
112 a = flist;
113 flist = (array *) a->primary;
114 } else {
115 if (achunksz == ARR_CHUNK) {
116 register arrchunk *l;
117
118 /* new chunk */
119 l = ALLOC(arrchunk, 1);
120 l->next = aclist;
121 aclist = l;
122 achunksz = 0;
123 }
124 a = &aclist->a[achunksz++];
125 }
126 a->size = size;
127 a->elts = (value *) NULL;
128 a->ref = 0;
129 a->odcount = 0; /* if swapped in, check objects */
130 a->hashed = (maphash *) NULL; /* only used for mappings */
131
132 return a;
133 }
134
135 /*
136 * NAME: array->new()
137 * DESCRIPTION: create a new array
138 */
139 array *arr_new(data, size)
140 dataspace *data;
141 register long size;
142 {
143 register array *a;
144
145 if (size > max_size) {
146 error("Array too large");
147 }
148 a = arr_alloc((unsigned short) size);
149 if (size > 0) {
150 a->elts = ALLOC(value, size);
151 }
152 a->tag = tag++;
153 a->odcount = odcount;
154 a->primary = &data->plane->alocal;
155 return a;
156 }
157
158 /*
159 * NAME: array->ext_new()
160 * DESCRIPTION: return an array, initialized for the benefit of the extension
161 * interface
162 */
163 array *arr_ext_new(data, size)
164 dataspace *data;
165 long size;
166 {
167 register int i;
168 register value *v;
169 array *a;
170
171 a = arr_new(data, size);
172 for (i = size, v = a->elts; i != 0; --i, v++) {
173 *v = nil_value;
174 }
175 return a;
176 }
177
178 /*
179 * NAME: array->del()
180 * DESCRIPTION: remove a reference from an array or mapping. If none are
181 * left, the array/mapping is removed.
182 */
183 void arr_del(a)
184 register array *a;
185 {
186 if (--(a->ref) == 0) {
187 register value *v;
188 register unsigned short i;
189
190 if ((v=a->elts) != (value *) NULL) {
191 for (i = a->size; i > 0; --i) {
192 i_del_value(v++);
193 }
194 FREE(a->elts);
195 }
196
197 if (a->hashed != (maphash *) NULL) {
198 register mapelt *e, *n, **t;
199
200 /*
201 * delete the hashtable of a mapping
202 */
203 for (i = a->hashed->size, t = a->hashed->table; i > 0; t++) {
204 for (e = *t; e != (mapelt *) NULL; e = n) {
205 i_del_value(&e->idx);
206 i_del_value(&e->val);
207 n = e->next;
208 e->next = fmelt;
209 fmelt = e;
210 --i;
211 }
212 }
213 FREE(a->hashed);
214 }
215
216 a->primary = (arrref *) flist;
217 flist = a;
218 }
219 }
220
221 /*
222 * NAME: array->freeall()
223 * DESCRIPTION: free all array chunks and mapping element chunks
224 */
225 void arr_freeall()
226 {
227 # ifdef DEBUG
228 register arrchunk *ac;
229 register meltchunk *mc;
230
231 /* free array chunks */
232 for (ac = aclist; ac != (arrchunk *) NULL; ) {
233 register arrchunk *f;
234
235 f = ac;
236 ac = ac->next;
237 FREE(f);
238 }
239 # endif
240 aclist = (arrchunk *) NULL;
241 achunksz = ARR_CHUNK;
242
243 flist = (array *) NULL;
244
245 # ifdef DEBUG
246 /* free mapping element chunks */
247 for (mc = meltlist; mc != (meltchunk *) NULL; ) {
248 register meltchunk *f;
249
250 f = mc;
251 mc = mc->next;
252 FREE(f);
253 }
254 # endif
255 meltlist = (meltchunk *) NULL;
256 meltchunksz = MELT_CHUNK;
257 fmelt = (mapelt *) NULL;
258 }
259
260 /*
261 * NAME: array->put()
262 * DESCRIPTION: Put an array in the merge table, and return its "index".
263 */
264 Uint arr_put(a)
265 register array *a;
266 {
267 register arrh **h;
268
269 for (h = &ht[(unsigned long) a % ARRMERGETABSZ]; *h != (arrh *) NULL;
270 h = &(*h)->next) {
271 if ((*h)->arr == a) {
272 return (*h)->index;
273 }
274 }
275 /*
276 * Add a new entry to the hash table.
277 */
278 if (ahchunksz == ARR_CHUNK) {
279 register arrhchunk *l;
280
281 l = ALLOC(arrhchunk, 1);
282 l->next = ahlist;
283 ahlist = l;
284 ahchunksz = 0;
285 }
286 *h = &ahlist->ah[ahchunksz++];
287 (*h)->next = (arrh *) NULL;
288 arr_ref((*h)->arr = a);
289 (*h)->index = idx;
290 (*h)->link = alink;
291 alink = h;
292
293 return idx++;
294 }
295
296 /*
297 * NAME: array->clear()
298 * DESCRIPTION: clear the array merge table
299 */
300 void arr_clear()
301 {
302 register arrh **h;
303 register arrhchunk *l;
304
305 /* clear hash table */
306 for (h = alink; h != (arrh **) NULL; ) {
307 register arrh *f;
308
309 f = *h;
310 *h = (arrh *) NULL;
311 arr_del(f->arr);
312 h = f->link;
313 }
314 alink = (arrh **) NULL;
315 idx = 0;
316
317 /* free array hash chunks */
318 for (l = ahlist; l != (arrhchunk *) NULL; ) {
319 register arrhchunk *f;
320
321 f = l;
322 l = l->next;
323 FREE(f);
324 }
325 ahlist = (arrhchunk *) NULL;
326 ahchunksz = ARR_CHUNK;
327 }
328
329
330 /*
331 * NAME: backup()
332 * DESCRIPTION: add an array backup to the backup chunk
333 */
334 static void backup(ac, a, elts, size, plane)
335 register abchunk **ac;
336 register array *a;
337 value *elts;
338 unsigned int size;
339 dataplane *plane;
340 {
341 register abchunk *c;
342 register arrbak *ab;
343
344 if (*ac == (abchunk *) NULL || (*ac)->chunksz == ABCHUNKSZ) {
345 c = ALLOC(abchunk, 1);
346 c->next = *ac;
347 c->chunksz = 0;
348 *ac = c;
349 } else {
350 c = *ac;
351 }
352
353 ab = &c->ab[c->chunksz++];
354 ab->arr = a;
355 ab->size = size;
356 ab->original = elts;
357 ab->plane = plane;
358 }
359
360 /*
361 * NAME: array->backup()
362 * DESCRIPTION: make a backup of the current elements of an array or mapping
363 */
364 void arr_backup(ac, a)
365 abchunk **ac;
366 register array *a;
367 {
368 register value *elts;
369 register unsigned short i;
370
371 if (a->size != 0) {
372 memcpy(elts = ALLOC(value, a->size), a->elts, a->size * sizeof(value));
373 for (i = a->size; i != 0; --i) {
374 switch (elts->type) {
375 case T_STRING:
376 str_ref(elts->u.string);
377 break;
378
379 case T_ARRAY:
380 case T_MAPPING:
381 arr_ref(elts->u.array);
382 break;
383 }
384 elts++;
385 }
386 elts -= a->size;
387 } else {
388 elts = (value *) NULL;
389 }
390 backup(ac, a, elts, a->size, a->primary->plane);
391 arr_ref(a);
392 }
393
394 /*
395 * NAME: array->commit()
396 * DESCRIPTION: commit current array values and discard originals
397 */
398 void arr_commit(ac, plane, merge)
399 abchunk **ac;
400 dataplane *plane;
401 int merge;
402 {
403 register abchunk *c, *n;
404 register arrbak *ab;
405 register short i;
406
407 c = *ac;
408 if (merge) {
409 *ac = (abchunk *) NULL;
410 }
411
412 while (c != (abchunk *) NULL) {
413 for (ab = c->ab, i = c->chunksz; --i >= 0; ab++) {
414 ac = d_commit_arr(ab->arr, plane, ab->plane);
415 if (merge) {
416 if (ac != (abchunk **) NULL) {
417 /* backup on previous plane */
418 backup(ac, ab->arr, ab->original, ab->size, ab->plane);
419 } else {
420 if (ab->original != (value *) NULL) {
421 register value *v;
422 register unsigned short j;
423
424 for (v = ab->original, j = ab->size; j != 0; v++, --j) {
425 i_del_value(v);
426 }
427 FREE(ab->original);
428 }
429 arr_del(ab->arr);
430 }
431 }
432 }
433
434 n = c->next;
435 if (merge) {
436 FREE(c);
437 }
438 c = n;
439 }
440 }
441
442 /*
443 * NAME: array->discard()
444 * DESCRIPTION: restore originals and discard current values
445 */
446 void arr_discard(ac)
447 abchunk **ac;
448 {
449 register abchunk *c, *n;
450 register arrbak *ab;
451 register short i;
452 register array *a;
453 register unsigned short j;
454
455 for (c = *ac, *ac = (abchunk *) NULL; c != (abchunk *) NULL; c = n) {
456 for (ab = c->ab, i = c->chunksz; --i >= 0; ab++) {
457 a = ab->arr;
458 d_discard_arr(a, ab->plane);
459
460 if (a->elts != (value *) NULL) {
461 register value *v;
462
463 for (v = a->elts, j = a->size; j != 0; v++, --j) {
464 i_del_value(v);
465 }
466 FREE(a->elts);
467 }
468
469 if (a->hashed != (maphash *) NULL) {
470 register mapelt *e, *n, **t;
471
472 for (j = a->hashed->size, t = a->hashed->table; j > 0; t++) {
473 for (e = *t; e != (mapelt *) NULL; e = n) {
474 i_del_value(&e->idx);
475 i_del_value(&e->val);
476 n = e->next;
477 e->next = fmelt;
478 fmelt = e;
479 --j;
480 }
481 }
482 FREE(a->hashed);
483 a->hashed = (maphash *) NULL;
484 }
485
486 a->elts = ab->original;
487 a->size = ab->size;
488 arr_del(a);
489 }
490
491 n = c->next;
492 FREE(c);
493 }
494 }
495
496
497 /*
498 * NAME: copytmp()
499 * DESCRIPTION: make temporary copies of values
500 */
501 static void copytmp(data, v1, a)
502 register dataspace *data;
503 register value *v1;
504 register array *a;
505 {
506 register value *v2;
507 register unsigned short n;
508
509 v2 = d_get_elts(a);
510 if (a->odcount == odcount) {
511 /*
512 * no need to check for destructed objects
513 */
514 memcpy(v1, v2, a->size * sizeof(value));
515 } else {
516 /*
517 * Copy and check for destructed objects. If destructed objects are
518 * found, they will be replaced by nil in the original array.
519 */
520 a->odcount = odcount;
521 for (n = a->size; n != 0; --n) {
522 if (v2->type == T_OBJECT && DESTRUCTED(v2)) {
523 d_assign_elt(data, a, v2, &nil_value);
524 }
525 *v1++ = *v2++;
526 }
527 }
528 }
529
530 /*
531 * NAME: array->add()
532 * DESCRIPTION: add two arrays
533 */
534 array *arr_add(data, a1, a2)
535 dataspace *data;
536 register array *a1, *a2;
537 {
538 register array *a;
539
540 a = arr_new(data, (long) a1->size + a2->size);
541 i_copy(a->elts, d_get_elts(a1), a1->size);
542 i_copy(a->elts + a1->size, d_get_elts(a2), a2->size);
543 d_ref_imports(a);
544
545 return a;
546 }
547
548 static int cmp P((cvoid*, cvoid*));
549
550 /*
551 * NAME: cmp()
552 * DESCRIPTION: compare two values
553 */
554 static int cmp(cv1, cv2)
555 cvoid *cv1, *cv2;
556 {
557 register value *v1, *v2;
558 register int i;
559 xfloat f1, f2;
560
561 v1 = (value *) cv1;
562 v2 = (value *) cv2;
563 i = v1->type - v2->type;
564 if (i != 0) {
565 return i; /* order by type */
566 }
567
568 switch (v1->type) {
569 case T_NIL:
570 return 0;
571
572 case T_INT:
573 return (v1->u.number <= v2->u.number) ?
574 (v1->u.number < v2->u.number) ? -1 : 0 :
575 1;
576
577 case T_FLOAT:
578 GET_FLT(v1, f1);
579 GET_FLT(v2, f2);
580 return flt_cmp(&f1, &f2);
581
582 case T_STRING:
583 return str_cmp(v1->u.string, v2->u.string);
584
585 case T_OBJECT:
586 return (v1->oindex <= v2->oindex) ?
587 (v1->oindex < v2->oindex) ? -1 : 0 :
588 1;
589
590 case T_ARRAY:
591 case T_MAPPING:
592 return (v1->u.array->tag <= v2->u.array->tag) ?
593 (v1->u.array->tag < v2->u.array->tag) ? -1 : 0 :
594 1;
595 }
596 }
597
598 /*
599 * NAME: search()
600 * DESCRIPTION: search for a value in an array
601 */
602 static int search(v1, v2, h, step, place)
603 register value *v1, *v2;
604 register unsigned short h;
605 register int step; /* 1 for arrays, 2 for mappings */
606 bool place;
607 {
608 register unsigned short l, m;
609 register Int c;
610 register value *v3;
611 register unsigned short mask;
612
613 mask = -step;
614 l = 0;
615 while (l < h) {
616 m = ((l + h) >> 1) & mask;
617 v3 = v2 + m;
618 c = cmp(v1, v3);
619 if (c == 0) {
620 if (T_INDEXED(v1->type) && v1->u.array != v3->u.array) {
621 /*
622 * It is possible for one object to export an array, both
623 * objects being swapped out after that, and the other object
624 * exporting the array back again. This gives two arrays with
625 * identical tags, which do not point to the same actual values
626 * and are not guaranteed to contain the same values, either.
627 * A possible way out is to give new tags to imported arrays
628 * and to resort all mappings before swapping them out.
629 * The solution used here is to check every array with this tag,
630 * and hope this kind of thing doesn't occur too often...
631 */
632 /* search forward */
633 for (;;) {
634 m += step;
635 v3 += step;
636 if (m == h || !T_INDEXED(v3->type)) {
637 break; /* out of range */
638 }
639 if (v1->u.array == v3->u.array) {
640 return m; /* found the right one */
641 }
642 if (v1->u.array->tag != v3->u.array->tag) {
643 break; /* wrong tag */
644 }
645 }
646 /* search backward */
647 m = ((l + h) >> 1) & mask;
648 v3 = v2 + m;
649 for (;;) {
650 v3 -= step;
651 if (m == l || !T_INDEXED(v3->type)) {
652 break; /* out of range */
653 }
654 m -= step;
655 if (v1->u.array == v3->u.array) {
656 return m; /* found the right one */
657 }
658 if (v1->u.array->tag != v3->u.array->tag) {
659 break; /* wrong tag */
660 }
661 }
662 break; /* not found */
663 }
664 return m; /* found */
665 } else if (c < 0) {
666 h = m; /* search in lower half */
667 } else {
668 l = m + step; /* search in upper half */
669 }
670 }
671 /*
672 * not found
673 */
674 return (place) ? l : -1;
675 }
676
677 /*
678 * NAME: array->sub()
679 * DESCRIPTION: subtract one array from another
680 */
681 array *arr_sub(data, a1, a2)
682 dataspace *data;
683 array *a1, *a2;
684 {
685 register value *v1, *v2, *v3;
686 register array *a3;
687 register unsigned short n, size;
688
689 if (a2->size == 0) {
690 /*
691 * array - ({ })
692 * Return a copy of the first array.
693 */
694 a3 = arr_new(data, (long) a1->size);
695 i_copy(a3->elts, d_get_elts(a1), a1->size);
696 d_ref_imports(a3);
697 return a3;
698 }
699
700 /* create new array */
701 a3 = arr_new(data, (long) a1->size);
702 if (a3->size == 0) {
703 /* subtract from empty array */
704 return a3;
705 }
706 size = a2->size;
707
708 /* copy and sort values of subtrahend */
709 copytmp(data, v2 = ALLOCA(value, size), a2);
710 qsort(v2, size, sizeof(value), cmp);
711
712 v1 = d_get_elts(a1);
713 v3 = a3->elts;
714 if (a1->odcount == odcount) {
715 for (n = a1->size; n > 0; --n) {
716 if (search(v1, v2, size, 1, FALSE) < 0) {
717 /*
718 * not found in subtrahend: copy to result array
719 */
720 i_ref_value(v1);
721 *v3++ = *v1;
722 }
723 v1++;
724 }
725 } else {
726 a1->odcount = odcount;
727 for (n = a1->size; n > 0; --n) {
728 if (v1->type == T_OBJECT && DESTRUCTED(v1)) {
729 /* replace destructed object by nil */
730 d_assign_elt(a1->primary->data, a1, v1, &nil_value);
731 }
732 if (search(v1, v2, size, 1, FALSE) < 0) {
733 /*
734 * not found in subtrahend: copy to result array
735 */
736 i_ref_value(v1);
737 *v3++ = *v1;
738 }
739 v1++;
740 }
741 }
742 AFREE(v2); /* free copy of values of subtrahend */
743
744 a3->size = v3 - a3->elts;
745 if (a3->size == 0) {
746 FREE(a3->elts);
747 a3->elts = (value *) NULL;
748 }
749
750 d_ref_imports(a3);
751 return a3;
752 }
753
754 /*
755 * NAME: array->intersect()
756 * DESCRIPTION: A - (A - B). If A and B are sets, the result is a set also.
757 */
758 array *arr_intersect(data, a1, a2)
759 dataspace *data;
760 array *a1, *a2;
761 {
762 register value *v1, *v2, *v3;
763 register array *a3;
764 register unsigned short n, size;
765
766 if (a1->size == 0 || a2->size == 0) {
767 /* array & ({ }) */
768 return arr_new(data, 0L);
769 }
770
771 /* create new array */
772 a3 = arr_new(data, (long) a1->size);
773 size = a2->size;
774
775 /* copy and sort values of 2nd array */
776 copytmp(data, v2 = ALLOCA(value, size), a2);
777 qsort(v2, size, sizeof(value), cmp);
778
779 v1 = d_get_elts(a1);
780 v3 = a3->elts;
781 if (a1->odcount == odcount) {
782 for (n = a1->size; n > 0; --n) {
783 if (search(v1, v2, a2->size, 1, FALSE) >= 0) {
784 /*
785 * element is in both arrays: copy to result array
786 */
787 i_ref_value(v1);
788 *v3++ = *v1;
789 }
790 v1++;
791 }
792 } else {
793 a1->odcount = odcount;
794 for (n = a1->size; n > 0; --n) {
795 if (v1->type == T_OBJECT && DESTRUCTED(v1)) {
796 /* replace destructed object by nil */
797 d_assign_elt(a1->primary->data, a1, v1, &nil_value);
798 }
799 if (search(v1, v2, a2->size, 1, FALSE) >= 0) {
800 /*
801 * element is in both arrays: copy to result array
802 */
803 i_ref_value(v1);
804 *v3++ = *v1;
805 }
806 v1++;
807 }
808 }
809 AFREE(v2); /* free copy of values of 2nd array */
810
811 a3->size = v3 - a3->elts;
812 if (a3->size == 0) {
813 FREE(a3->elts);
814 a3->elts = (value *) NULL;
815 }
816
817 d_ref_imports(a3);
818 return a3;
819 }
820
821 /*
822 * NAME: array->setadd()
823 * DESCRIPTION: A + (B - A). If A and B are sets, the result is a set also.
824 */
825 array *arr_setadd(data, a1, a2)
826 dataspace *data;
827 array *a1, *a2;
828 {
829 register value *v, *v1, *v2;
830 value *v3;
831 register array *a3;
832 register unsigned short n, size;
833
834 if (a1->size == 0) {
835 /* ({ }) | array */
836 a3 = arr_new(data, (long) a2->size);
837 i_copy(a3->elts, d_get_elts(a2), a2->size);
838 d_ref_imports(a3);
839 return a3;
840 }
841 if (a2->size == 0) {
842 /* array | ({ }) */
843 a3 = arr_new(data, (long) a1->size);
844 i_copy(a3->elts, d_get_elts(a1), a1->size);
845 d_ref_imports(a3);
846 return a3;
847 }
848
849 /* make room for elements to add */
850 v3 = ALLOCA(value, a2->size);
851
852 /* copy and sort values of 1st array */
853 copytmp(data, v1 = ALLOCA(value, size = a1->size), a1);
854 qsort(v1, size, sizeof(value), cmp);
855
856 v = v3;
857 v2 = d_get_elts(a2);
858 if (a2->odcount == odcount) {
859 for (n = a2->size; n > 0; --n) {
860 if (search(v2, v1, size, 1, FALSE) < 0) {
861 /*
862 * element is only in second array: copy to result array
863 */
864 *v++ = *v2;
865 }
866 v2++;
867 }
868 } else {
869 a2->odcount = odcount;
870 for (n = a2->size; n > 0; --n) {
871 if (v2->type == T_OBJECT && DESTRUCTED(v2)) {
872 /* replace destructed object by nil */
873 d_assign_elt(a2->primary->data, a2, v2, &nil_value);
874 }
875 if (search(v2, v1, size, 1, FALSE) < 0) {
876 /*
877 * element is only in second array: copy to result array
878 */
879 *v++ = *v2;
880 }
881 v2++;
882 }
883 }
884 AFREE(v1); /* free copy of values of 1st array */
885
886 n = v - v3;
887 if ((long) size + n > max_size) {
888 AFREE(v3);
889 error("Array too large");
890 }
891
892 a3 = arr_new(data, (long) size + n);
893 i_copy(a3->elts, a1->elts, size);
894 i_copy(a3->elts + size, v3, n);
895 AFREE(v3);
896
897 d_ref_imports(a3);
898 return a3;
899 }
900
901 /*
902 * NAME: array->setxadd()
903 * DESCRIPTION: (A - B) + (B - A). If A and B are sets, the result is a set
904 * also.
905 */
906 array *arr_setxadd(data, a1, a2)
907 dataspace *data;
908 array *a1, *a2;
909 {
910 register value *v, *w, *v1, *v2;
911 value *v3;
912 register array *a3;
913 register unsigned short n, size;
914 unsigned short num;
915
916 if (a1->size == 0) {
917 /* ({ }) ^ array */
918 a3 = arr_new(data, (long) a2->size);
919 i_copy(a3->elts, d_get_elts(a2), a2->size);
920 d_ref_imports(a3);
921 return a3;
922 }
923 if (a2->size == 0) {
924 /* array ^ ({ }) */
925 a3 = arr_new(data, (long) a1->size);
926 i_copy(a3->elts, d_get_elts(a1), a1->size);
927 d_ref_imports(a3);
928 return a3;
929 }
930
931 /* copy values of 1st array */
932 copytmp(data, v1 = ALLOCA(value, size = a1->size), a1);
933
934 /* copy and sort values of 2nd array */
935 copytmp(data, v2 = ALLOCA(value, size = a2->size), a2);
936 qsort(v2, size, sizeof(value), cmp);
937
938 /* room for first half of result */
939 v3 = ALLOCA(value, a1->size);
940
941 v = v3;
942 w = v1;
943 for (n = a1->size; n > 0; --n) {
944 if (search(v1, v2, size, 1, FALSE) < 0) {
945 /*
946 * element is only in first array: copy to result array
947 */
948 *v++ = *v1;
949 } else {
950 /*
951 * element is in both: keep it for the next round
952 */
953 *w++ = *v1;
954 }
955 v1++;
956 }
957 num = v - v3;
958
959 /* sort copy of 1st array */
960 v1 -= a1->size;
961 qsort(v1, size = w - v1, sizeof(value), cmp);
962
963 v = v2;
964 w = a2->elts;
965 for (n = a2->size; n > 0; --n) {
966 if (search(w, v1, size, 1, FALSE) < 0) {
967 /*
968 * element is only in second array: copy to 2nd result array
969 */
970 *v++ = *w;
971 }
972 w++;
973 }
974
975 n = v - v2;
976 if ((long) num + n > max_size) {
977 AFREE(v3);
978 AFREE(v2);
979 AFREE(v1);
980 error("Array too large");
981 }
982
983 a3 = arr_new(data, (long) num + n);
984 i_copy(a3->elts, v3, num);
985 i_copy(a3->elts + num, v2, n);
986 AFREE(v3);
987 AFREE(v2);
988 AFREE(v1);
989
990 d_ref_imports(a3);
991 return a3;
992 }
993
994 /*
995 * NAME: array->index()
996 * DESCRIPTION: index an array
997 */
998 unsigned short arr_index(a, l)
999 register array *a;
1000 register long l;
1001 {
1002 if (l < 0 || l >= (long) a->size) {
1003 error("Array index out of range");
1004 }
1005 return l;
1006 }
1007
1008 /*
1009 * NAME: array->ckrange()
1010 * DESCRIPTION: check an array subrange
1011 */
1012 void arr_ckrange(a, l1, l2)
1013 array *a;
1014 register long l1, l2;
1015 {
1016 if (l1 < 0 || l1 > l2 + 1 || l2 >= (long) a->size) {
1017 error("Invalid array range");
1018 }
1019 }
1020
1021 /*
1022 * NAME: array->range()
1023 * DESCRIPTION: return a subrange of an array
1024 */
1025 array *arr_range(data, a, l1, l2)
1026 dataspace *data;
1027 register array *a;
1028 register long l1, l2;
1029 {
1030 register array *range;
1031
1032 if (l1 < 0 || l1 > l2 + 1 || l2 >= (long) a->size) {
1033 error("Invalid array range");
1034 }
1035
1036 range = arr_new(data, l2 - l1 + 1);
1037 i_copy(range->elts, d_get_elts(a) + l1, (unsigned short) (l2 - l1 + 1));
1038 d_ref_imports(range);
1039 return range;
1040 }
1041
1042
1043 /*
1044 * NAME: mapping->new()
1045 * DESCRIPTION: create a new mapping
1046 */
1047 array *map_new(data, size)
1048 dataspace *data;
1049 register long size;
1050 {
1051 array *m;
1052
1053 if (size > max_size << 1) {
1054 error("Mapping too large");
1055 }
1056 m = arr_alloc((unsigned short) size);
1057 if (size > 0) {
1058 m->elts = ALLOC(value, size);
1059 }
1060 m->tag = tag++;
1061 m->odcount = odcount;
1062 m->primary = &data->plane->alocal;
1063 return m;
1064 }
1065
1066 /*
1067 * NAME: mapping->sort()
1068 * DESCRIPTION: prune and sort a mapping
1069 */
1070 void map_sort(m)
1071 register array *m;
1072 {
1073 register unsigned short i, sz;
1074 register value *v, *w;
1075
1076 for (i = m->size, sz = 0, v = w = m->elts; i > 0; i -= 2) {
1077 if (!VAL_NIL(v + 1)) {
1078 *w++ = *v++;
1079 *w++ = *v++;
1080 sz += 2;
1081 } else {
1082 /* delete index and skip zero value */
1083 i_del_value(v);
1084 v += 2;
1085 }
1086 }
1087
1088 if (sz != 0) {
1089 qsort(v = m->elts, i = sz >> 1, 2 * sizeof(value), cmp);
1090 while (--i != 0) {
1091 if (cmp((cvoid *) v, (cvoid *) &v[2]) == 0 &&
1092 (!T_INDEXED(v->type) || v->u.array == v[2].u.array)) {
1093 error("Identical indices in mapping");
1094 }
1095 v += 2;
1096 }
1097 } else if (m->size > 0) {
1098 FREE(m->elts);
1099 m->elts = (value *) NULL;
1100 }
1101 m->size = sz;
1102 }
1103
1104 /*
1105 * NAME: mapping->dehash()
1106 * DESCRIPTION: merge hashtable component with array part of mapping
1107 */
1108 static void map_dehash(m)
1109 register array *m;
1110 {
1111 register unsigned short hashsize;
1112
1113 /*
1114 * convert hashtable into sorted array
1115 */
1116 hashsize = m->hashed->size << 1;
1117 if (hashsize != 0) {
1118 register value *v1, *v2, *v3;
1119 register unsigned short i, j;
1120 register mapelt *e, *n, **t;
1121
1122 v2 = ALLOCA(value, m->hashed->size << 1);
1123 t = m->hashed->table;
1124 for (i = m->hashed->size; i > 0; ) {
1125 for (e = *t++; e != (mapelt *) NULL; --i, e = n) {
1126 *v2++ = e->idx;
1127 *v2++ = e->val;
1128 n = e->next;
1129 e->next = fmelt;
1130 fmelt = e;
1131 }
1132 }
1133 v2 -= hashsize;
1134 qsort(v2, hashsize >> 1, 2 * sizeof(value), cmp);
1135
1136 /*
1137 * merge the two value arrays
1138 */
1139 v1 = m->elts;
1140 v3 = ALLOC(value, m->size + hashsize);
1141 for (i = m->size, j = hashsize; i > 0 && j > 0; ) {
1142 if (cmp(v1, v2) <= 0) {
1143 *v3++ = *v1++;
1144 *v3++ = *v1++;
1145 i -= 2;
1146 } else {
1147 *v3++ = *v2++;
1148 *v3++ = *v2++;
1149 j -= 2;
1150 }
1151 }
1152
1153 /*
1154 * copy tails of arrays
1155 */
1156 memcpy(v3, v1, i * sizeof(value));
1157 v3 += i;
1158 memcpy(v3, v2, j * sizeof(value));
1159 v3 += j;
1160
1161 AFREE(v2 - (hashsize - j));
1162 if (m->size > 0) {
1163 FREE(m->elts);
1164 }
1165 m->size += hashsize;
1166 m->elts = v3 - m->size;
1167 }
1168
1169 FREE(m->hashed);
1170 m->hashed = (maphash *) NULL;
1171 }
1172
1173 /*
1174 * NAME: mapping->clean()
1175 * DESCRIPTION: remove destructed objects from mapping
1176 */
1177 static void map_clean(data, m)
1178 register dataspace *data;
1179 register array *m;
1180 {
1181 register value *v1, *v2;
1182 register unsigned short i, size;
1183
1184 if (m->odcount == odcount) {
1185 return; /* no destructed objects */
1186 }
1187
1188 if (m->hashed != (maphash *) NULL &&
1189 (!THISPLANE(m->primary) || !SAMEPLANE(data, m->primary->data))) {
1190 map_dehash(m);
1191 }
1192
1193 /*
1194 * remove destructed objects in the array
1195 */
1196 if (m->size != 0) {
1197 size = 0;
1198 v1 = v2 = d_get_elts(m);
1199 for (i = m->size; i > 0; i -= 2) {
1200 if (v2->type == T_OBJECT && DESTRUCTED(v2)) {
1201 /*
1202 * index is destructed object
1203 */
1204 d_assign_elt(data, m, v2 + 1, &nil_value);
1205 v2 += 2;
1206 } else if (v2[1].type == T_OBJECT && DESTRUCTED(&v2[1])) {
1207 /*
1208 * value is destructed object
1209 */
1210 d_assign_elt(data, m, v2, &nil_value);
1211 v2 += 2;
1212 } else {
1213 *v1++ = *v2++;
1214 *v1++ = *v2++;
1215 size += 2;
1216 }
1217 }
1218 if (size == 0) {
1219 FREE(m->elts);
1220 m->elts = (value *) NULL;
1221 }
1222 if (size != m->size) {
1223 d_change_map(m);
1224 }
1225 m->size = size;
1226 }
1227
1228 /*
1229 * remove destructed objects in the hash table
1230 */
1231 if (m->hashed != (maphash *) NULL && m->hashed->size != 0) {
1232 register mapelt *e, **p, **t;
1233
1234 size = 0;
1235 t = m->hashed->table;
1236 for (i = m->hashed->size; i > 0; ) {
1237 for (p = t++; (e=*p) != (mapelt *) NULL; --i) {
1238 if (e->idx.type == T_OBJECT && DESTRUCTED(&e->idx)) {
1239 /*
1240 * index is destructed object
1241 */
1242 d_assign_elt(data, m, &e->val, &nil_value);
1243 } else if (e->val.type == T_OBJECT && DESTRUCTED(&e->val)) {
1244 /*
1245 * value is destructed object
1246 */
1247 d_assign_elt(data, m, &e->idx, &nil_value);
1248 } else {
1249 size++;
1250 p = &e->next;
1251 continue;
1252 }
1253 *p = e->next;
1254 e->next = fmelt;
1255 fmelt = e;
1256 }
1257 }
1258 m->hashed->size = size;
1259 }
1260
1261 m->odcount = odcount; /* update */
1262 }
1263
1264 /*
1265 * NAME: mapping->compact()
1266 * DESCRIPTION: compact a mapping: put elements from the hash table into
1267 * the array, and remove destructed objects
1268 */
1269 void map_compact(data, m)
1270 register dataspace *data;
1271 register array *m;
1272 {
1273 register value *v1, *v2;
1274 register unsigned short i, arrsize, hashsize;
1275
1276 if ((m->size == 0 || m->odcount == odcount) &&
1277 (m->hashed == (maphash *) NULL || m->hashed->size == 0)) {
1278 /* skip empty or unchanged mapping */
1279 return;
1280 }
1281
1282 if (m->hashed != (maphash *) NULL &&
1283 (!THISPLANE(m->primary) || !SAMEPLANE(data, m->primary->data))) {
1284 map_dehash(m);
1285 }
1286
1287 arrsize = 0;
1288 if (m->size > 0) {
1289 v1 = v2 = d_get_elts(m);
1290 if (m->odcount != odcount) {
1291 /*
1292 * remove destructed objects in the array
1293 */
1294 for (i = m->size; i > 0; i -= 2) {
1295 if (v2->type == T_OBJECT && DESTRUCTED(v2)) {
1296 /*
1297 * index is destructed object
1298 */
1299 d_assign_elt(data, m, v2 + 1, &nil_value);
1300 v2 += 2;
1301 } else if (v2[1].type == T_OBJECT && DESTRUCTED(&v2[1])) {
1302 /*
1303 * value is destructed object
1304 */
1305 d_assign_elt(data, m, v2, &nil_value);
1306 v2 += 2;
1307 } else {
1308 *v1++ = *v2++;
1309 *v1++ = *v2++;
1310 arrsize += 2;
1311 }
1312 }
1313 } else {
1314 arrsize = m->size;
1315 }
1316 }
1317
1318 /*
1319 * convert hashtable into sorted array
1320 */
1321 hashsize = 0;
1322 if (m->hashed != (maphash *) NULL) {
1323 if (m->hashed->size != 0) {
1324 register mapelt *e, *n, **t;
1325
1326 v2 = ALLOCA(value, m->hashed->size << 1);
1327 t = m->hashed->table;
1328 if (m->odcount == odcount) {
1329 for (i = m->hashed->size; i > 0; ) {
1330 for (e = *t++; e != (mapelt *) NULL; --i, e = n) {
1331 *v2++ = e->idx;
1332 *v2++ = e->val;
1333 n = e->next;
1334 e->next = fmelt;
1335 fmelt = e;
1336 }
1337 }
1338 hashsize = m->hashed->size << 1;
1339 } else {
1340 for (i = m->hashed->size; i > 0; ) {
1341 for (e = *t++; e != (mapelt *) NULL; --i, e = n) {
1342 if (e->idx.type == T_OBJECT && DESTRUCTED(&e->idx)) {
1343 /*
1344 * index is destructed object
1345 */
1346 d_assign_elt(data, m, &e->val, &nil_value);
1347 } else if (e->val.type == T_OBJECT &&
1348 DESTRUCTED(&e->val)) {
1349 /*
1350 * value is destructed object
1351 */
1352 d_assign_elt(data, m, &e->idx, &nil_value);
1353 } else {
1354 /*
1355 * copy to array
1356 */
1357 *v2++ = e->idx;
1358 *v2++ = e->val;
1359 hashsize += 2;
1360 }
1361 n = e->next;
1362 e->next = fmelt;
1363 fmelt = e;
1364 }
1365 }
1366 }
1367 if (hashsize == 0) {
1368 AFREE(v2); /* nothing in the hash table */
1369 } else {
1370 v2 -= hashsize;
1371 qsort(v2, hashsize >> 1, 2 * sizeof(value), cmp);
1372 }
1373 }
1374 FREE(m->hashed);
1375 m->hashed = (maphash *) NULL;
1376 }
1377
1378 m->odcount = odcount; /* update */
1379
1380 if (hashsize > 0) {
1381 register value *v3;
1382 register unsigned short j;
1383
1384 /*
1385 * merge the two value arrays
1386 */
1387 v1 = m->elts;
1388 v3 = ALLOC(value, arrsize + hashsize);
1389 for (i = arrsize, j = hashsize; i > 0 && j > 0; ) {
1390 if (cmp(v1, v2) <= 0) {
1391 *v3++ = *v1++;
1392 *v3++ = *v1++;
1393 i -= 2;
1394 } else {
1395 *v3++ = *v2++;
1396 *v3++ = *v2++;
1397 j -= 2;
1398 }
1399 }
1400
1401 /*
1402 * copy tails of arrays
1403 */
1404 memcpy(v3, v1, i * sizeof(value));
1405 v3 += i;
1406 memcpy(v3, v2, j * sizeof(value));
1407 v3 += j;
1408
1409 AFREE(v2 - (hashsize - j));
1410 if (m->size > 0) {
1411 FREE(m->elts);
1412 }
1413 m->size = arrsize + hashsize;
1414 m->elts = v3 - m->size;
1415 } else if (arrsize != m->size) {
1416 /*
1417 * destructed objects were removed
1418 */
1419 if (arrsize == 0) {
1420 FREE(m->elts);
1421 m->elts = (value *) NULL;
1422 }
1423 m->size = arrsize;
1424 d_change_map(m);
1425 }
1426 }
1427
1428 /*
1429 * NAME: mapping->size()
1430 * DESCRIPTION: return the size of a mapping
1431 */
1432 unsigned short map_size(data, m)
1433 dataspace *data;
1434 register array *m;
1435 {
1436 unsigned short size;
1437
1438 map_clean(data, m);
1439 size = m->size >> 1;
1440 if (m->hashed != (maphash *) NULL) {
1441 size += m->hashed->size;
1442 }
1443 return size;
1444 }
1445
1446 /*
1447 * NAME: mapping->add()
1448 * DESCRIPTION: add two mappings
1449 */
1450 array *map_add(data, m1, m2)
1451 dataspace *data;
1452 array *m1, *m2;
1453 {
1454 register value *v1, *v2, *v3;
1455 register unsigned short n1, n2;
1456 register Int c;
1457 array *m3;
1458
1459 map_compact(data, m1);
1460 map_compact(data, m2);
1461 m3 = map_new(data, (long) m1->size + m2->size);
1462 if (m3->size == 0) {
1463 /* add two empty mappings */
1464 return m3;
1465 }
1466
1467 v1 = m1->elts;
1468 v2 = m2->elts;
1469 v3 = m3->elts;
1470 for (n1 = m1->size, n2 = m2->size; n1 > 0 && n2 > 0; ) {
1471 c = cmp(v1, v2);
1472 if (c < 0) {
1473 /* the smaller element is in m1 */
1474 i_copy(v3, v1, 2);
1475 v1 += 2; v3 += 2; n1 -= 2;
1476 } else {
1477 /* the smaller - or overriding - element is in m2 */
1478 i_copy(v3, v2, 2);
1479 v3 += 2;
1480 if (c == 0) {
1481 /* equal elements? */
1482 if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) {
1483 register value *v;
1484 register unsigned short n;
1485
1486 /*
1487 * The array tags are the same, but the arrays are not.
1488 * Check ahead to see if the array is somewhere else
1489 * in m2; if not, copy the element from m1 as well.
1490 */
1491 v = v2; n = n2;
1492 for (;;) {
1493 v += 2; n -= 2;
1494 if (n == 0 || !T_INDEXED(v->type) ||
1495 v->u.array->tag != v1->u.array->tag) {
1496 /* not in m2 */
1497 i_copy(v3, v1, 2);
1498 v3 += 2;
1499 break;
1500 }
1501 if (v->u.array == v1->u.array) {
1502 /* also in m2 */
1503 break;
1504 }
1505 }
1506 }
1507 /* skip m1 */
1508 v1 += 2; n1 -= 2;
1509 }
1510 v2 += 2; n2 -= 2;
1511 }
1512 }
1513
1514 /* copy tail part of m1 */
1515 i_copy(v3, v1, n1);
1516 v3 += n1;
1517 /* copy tail part of m2 */
1518 i_copy(v3, v2, n2);
1519 v3 += n2;
1520
1521 m3->size = v3 - m3->elts;
1522 if (m3->size == 0) {
1523 FREE(m3->elts);
1524 m3->elts = (value *) NULL;
1525 }
1526
1527 d_ref_imports(m3);
1528 return m3;
1529 }
1530
1531 /*
1532 * NAME: mapping->sub()
1533 * DESCRIPTION: subtract an array from a mapping
1534 */
1535 array *map_sub(data, m1, a2)
1536 dataspace *data;
1537 array *m1, *a2;
1538 {
1539 register value *v1, *v2, *v3;
1540 register unsigned short n1, n2, size;
1541 register Int c;
1542 array *m3;
1543
1544 map_compact(data, m1);
1545 m3 = map_new(data, (long) m1->size);
1546 if (m1->size == 0) {
1547 /* subtract from empty mapping */
1548 return m3;
1549 }
1550 if ((size=a2->size) == 0) {
1551 /* subtract empty array */
1552 i_copy(m3->elts, m1->elts, m1->size);
1553 d_ref_imports(m3);
1554 return m3;
1555 }
1556
1557 /* copy and sort values of array */
1558 copytmp(data, v2 = ALLOCA(value, size), a2);
1559 qsort(v2, size, sizeof(value), cmp);
1560
1561 v1 = m1->elts;
1562 v3 = m3->elts;
1563 for (n1 = m1->size, n2 = size; n1 > 0 && n2 > 0; ) {
1564 c = cmp(v1, v2);
1565 if (c < 0) {
1566 /* the smaller element is in m1 */
1567 i_copy(v3, v1, 2);
1568 v1 += 2; v3 += 2; n1 -= 2;
1569 } else if (c > 0) {
1570 /* the smaller element is in a2 */
1571 v2++; --n2;
1572 } else {
1573 /* equal elements? */
1574 if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) {
1575 register value *v;
1576 register unsigned short n;
1577
1578 /*
1579 * The array tags are the same, but the arrays are not.
1580 * Check ahead to see if the array is somewhere else
1581 * in a2; if not, copy the element from m1.
1582 */
1583 v = v2; n = n2;
1584 for (;;) {
1585 v++; --n;
1586 if (n == 0 || !T_INDEXED(v->type) ||
1587 v->u.array->tag != v1->u.array->tag) {
1588 /* not in a2 */
1589 i_copy(v3, v1, 2);
1590 v3 += 2;
1591 break;
1592 }
1593 if (v->u.array == v1->u.array) {
1594 /* also in a2 */
1595 break;
1596 }
1597 }
1598 }
1599 /* skip m1 */
1600 v1 += 2; n1 -= 2;
1601 }
1602 }
1603 AFREE(v2 - (size - n2));
1604
1605 /* copy tail part of m1 */
1606 i_copy(v3, v1, n1);
1607 v3 += n1;
1608
1609 m3->size = v3 - m3->elts;
1610 if (m3->size == 0) {
1611 FREE(m3->elts);
1612 m3->elts = (value *) NULL;
1613 }
1614
1615 d_ref_imports(m3);
1616 return m3;
1617 }
1618
1619 /*
1620 * NAME: mapping->intersect()
1621 * DESCRIPTION: intersect a mapping with an array
1622 */
1623 array *map_intersect(data, m1, a2)
1624 dataspace *data;
1625 array *m1, *a2;
1626 {
1627 register value *v1, *v2, *v3;
1628 register unsigned short n1, n2, size;
1629 register Int c;
1630 array *m3;
1631
1632 map_compact(data, m1);
1633 if ((size=a2->size) == 0) {
1634 /* intersect with empty array */
1635 return map_new(data, 0L);
1636 }
1637 m3 = map_new(data, (long) m1->size);
1638 if (m1->size == 0) {
1639 /* intersect with empty mapping */
1640 return m3;
1641 }
1642
1643 /* copy and sort values of array */
1644 copytmp(data, v2 = ALLOCA(value, size), a2);
1645 qsort(v2, size, sizeof(value), cmp);
1646
1647 v1 = m1->elts;
1648 v3 = m3->elts;
1649 for (n1 = m1->size, n2 = size; n1 > 0 && n2 > 0; ) {
1650 c = cmp(v1, v2);
1651 if (c < 0) {
1652 /* the smaller element is in m1 */
1653 v1 += 2; n1 -= 2;
1654 } else if (c > 0) {
1655 /* the smaller element is in a2 */
1656 v2++; --n2;
1657 } else {
1658 /* equal elements? */
1659 if (T_INDEXED(v1->type) && v1->u.array != v2->u.array) {
1660 register value *v;
1661 register unsigned short n;
1662
1663 /*
1664 * The array tags are the same, but the arrays are not.
1665 * Check ahead to see if the array is somewhere else
1666 * in a2; if not, don't copy the element from m1.
1667 */
1668 v = v2; n = n2;
1669 for (;;) {
1670 v++; --n;
1671 if (n == 0 || !T_INDEXED(v->type) ||
1672 v->u.array->tag != v1->u.array->tag) {
1673 /* not in a2 */
1674 break;
1675 }
1676 if (v->u.array == v1->u.array) {
1677 /* also in a2 */
1678 i_copy(v3, v1, 2);
1679 v3 += 2; v1 += 2; n1 -= 2;
1680 break;
1681 }
1682 }
1683 } else {
1684 /* equal */
1685 i_copy(v3, v1, 2);
1686 v3 += 2; v1 += 2; n1 -= 2;
1687 }
1688 v2++; --n2;
1689 }
1690 }
1691 AFREE(v2 - (size - n2));
1692
1693 m3->size = v3 - m3->elts;
1694 if (m3->size == 0) {
1695 FREE(m3->elts);
1696 m3->elts = (value *) NULL;
1697 }
1698
1699 d_ref_imports(m3);
1700 return m3;
1701 }
1702
1703 /*
1704 * NAME: mapping->grow()
1705 * DESCRIPTION: add an element to a mapping
1706 */
1707 static mapelt *map_grow(data, m, hashval)
1708 dataspace *data;
1709 register array *m;
1710 unsigned short hashval;
1711 {
1712 register maphash *h;
1713 register mapelt *e;
1714 register unsigned short i;
1715
1716 h = m->hashed;
1717 if ((m->size >> 1) + ((h == (maphash *) NULL) ? 0 : h->size) >= max_size) {
1718 map_compact(data, m);
1719 if (m->size >> 1 >= max_size) {
1720 error("Mapping too large to grow");
1721 }
1722 h = (maphash *) NULL;
1723 }
1724
1725 if (h == (maphash *) NULL) {
1726 /*
1727 * add hash table to this mapping
1728 */
1729 m->hashed = h = (maphash *)
1730 ALLOC(char, sizeof(maphash) + (MTABLE_SIZE - 1) * sizeof(mapelt*));
1731 h->size = 0;
1732 h->tablesize = MTABLE_SIZE;
1733 memset(h->table, '\0', MTABLE_SIZE * sizeof(mapelt*));
1734 } else if (h->size << 2 >= h->tablesize * 3) {
1735 register mapelt *n, **t;
1736 register unsigned short j;
1737
1738 /*
1739 * extend hash table for this mapping
1740 */
1741 i = h->tablesize << 1;
1742 h = (maphash *) ALLOC(char,
1743 sizeof(maphash) + (i - 1) * sizeof(mapelt*));
1744 h->size = m->hashed->size;
1745 h->tablesize = i;
1746 memset(h->table, '\0', i * sizeof(mapelt*));
1747 /*
1748 * copy entries from old hashtable to new hashtable
1749 */
1750 for (j = h->size, t = m->hashed->table; j > 0; t++) {
1751 for (e = *t; e != (mapelt *) NULL; e = n) {
1752 n = e->next;
1753 i = e->hashval % h->tablesize;
1754 e->next = h->table[i];
1755 h->table[i] = e;
1756 --j;
1757 }
1758 }
1759 FREE(m->hashed);
1760 m->hashed = h;
1761 }
1762 h->size++;
1763
1764 if (fmelt != (mapelt *) NULL) {
1765 /* from free list */
1766 e = fmelt;
1767 fmelt = e->next;
1768 } else {
1769 if (meltchunksz == MELT_CHUNK) {
1770 register meltchunk *l;
1771
1772 /* new chunk */
1773 l = ALLOC(meltchunk, 1);
1774 l->next = meltlist;
1775 meltlist = l;
1776 meltchunksz = 0;
1777 }
1778 e = &meltlist->e[meltchunksz++];
1779 }
1780 e->hashval = hashval;
1781 e->idx = nil_value;
1782 e->val = nil_value;
1783 i = hashval % h->tablesize;
1784 e->next = h->table[i];
1785 h->table[i] = e;
1786
1787 return e;
1788 }
1789
1790 /*
1791 * NAME: mapping->index()
1792 * DESCRIPTION: Index a mapping with a value. If a third argument is supplied,
1793 * perform an assignment; otherwise return the indexed value.
1794 */
1795 value *map_index(data, m, val, elt)
1796 dataspace *data;
1797 register array *m;
1798 value *val, *elt;
1799 {
1800 register unsigned short i;
1801 bool del;
1802
1803 if (elt != (value *) NULL && VAL_NIL(elt)) {
1804 elt = (value *) NULL;
1805 del = TRUE;
1806 } else {
1807 del = FALSE;
1808 }
1809
1810 if (m->hashed != (maphash *) NULL &&
1811 (!THISPLANE(m->primary) || !SAMEPLANE(data, m->primary->data))) {
1812 map_dehash(m);
1813 }
1814
1815 if (m->size > 0) {
1816 register int n;
1817
1818 n = search(val, d_get_elts(m), m->size, 2, FALSE);
1819 if (n >= 0) {
1820 register value *v;
1821
1822 /*
1823 * found in the array
1824 */
1825 v = &m->elts[n];
1826 if (elt != (value *) NULL) {
1827 /*
1828 * change the element
1829 */
1830 d_assign_elt(data, m, v + 1, elt);
1831 if (val->type == T_OBJECT) {
1832 v->modified = TRUE;
1833 v->u.objcnt = val->u.objcnt; /* refresh */
1834 }
1835 } else if (del ||
1836 (val->type == T_OBJECT &&
1837 val->u.objcnt != v->u.objcnt)) {
1838 /*
1839 * delete the element
1840 */
1841 d_assign_elt(data, m, v, &nil_value);
1842 d_assign_elt(data, m, v + 1, &nil_value);
1843
1844 m->size -= 2;
1845 if (m->size == 0) {
1846 /* last element removed */
1847 FREE(m->elts);
1848 m->elts = (value *) NULL;
1849 } else {
1850 /* move tail */
1851 memcpy(v, v + 2, (m->size - n) * sizeof(value));
1852 }
1853 d_change_map(m);
1854 return &nil_value;
1855 }
1856 return v + 1;
1857 }
1858 }
1859
1860 switch (val->type) {
1861 case T_NIL:
1862 i = 4747;
1863 break;
1864
1865 case T_INT:
1866 i = val->u.number;
1867 break;
1868
1869 case T_FLOAT:
1870 i = VFLT_HASH(val);
1871 break;
1872
1873 case T_STRING:
1874 i = hashstr(val->u.string->text, STRMAPHASHSZ) ^ val->u.string->len;
1875 break;
1876
1877 case T_OBJECT:
1878 i = val->oindex;
1879 break;
1880
1881 case T_ARRAY:
1882 case T_MAPPING:
1883 i = (unsigned short) ((unsigned long) val->u.array >> 3);
1884 break;
1885 }
1886
1887 if (m->hashed != (maphash *) NULL) {
1888 register mapelt *e, **p;
1889
1890 for (p = &m->hashed->table[i % m->hashed->tablesize];
1891 (e=*p) != (mapelt *) NULL; p = &e->next) {
1892 if (cmp(val, &e->idx) == 0 &&
1893 (!T_INDEXED(val->type) || val->u.array == e->idx.u.array)) {
1894 /*
1895 * found in the hashtable
1896 */
1897 if (elt != (value *) NULL) {
1898 /*
1899 * change element
1900 */
1901 d_assign_elt(data, m, &e->val, elt);
1902 if (val->type == T_OBJECT) {
1903 e->idx.u.objcnt = val->u.objcnt; /* refresh */
1904 }
1905 } else if (del ||
1906 (val->type == T_OBJECT &&
1907 val->u.objcnt != e->idx.u.objcnt)) {
1908 /*
1909 * delete element
1910 */
1911 d_assign_elt(data, m, &e->idx, &nil_value);
1912 d_assign_elt(data, m, &e->val, &nil_value);
1913
1914 *p = e->next;
1915 e->next = fmelt;
1916 fmelt = e;
1917 m->hashed->size--;
1918 return &nil_value;
1919 }
1920 return &e->val;
1921 }
1922 }
1923 }
1924
1925 if (elt != (value *) NULL) {
1926 register mapelt *e;
1927
1928 /*
1929 * extend mapping
1930 */
1931 e = map_grow(data, m, i);
1932 d_assign_elt(data, m, &e->idx, val);
1933 d_assign_elt(data, m, &e->val, elt);
1934 d_change_map(m);
1935 }
1936
1937 /*
1938 * not found
1939 */
1940 return &nil_value;
1941 }
1942
1943 /*
1944 * NAME: mapping->range()
1945 * DESCRIPTION: return a mapping value subrange
1946 */
1947 array *map_range(data, m, v1, v2)
1948 dataspace *data;
1949 array *m;
1950 register value *v1, *v2;
1951 {
1952 register unsigned short from, to;
1953 register array *range;
1954
1955 map_compact(data, m);
1956
1957 /* determine subrange */
1958 from = (v1 == (value *) NULL) ? 0 : search(v1, m->elts, m->size, 2, TRUE);
1959 if (v2 == (value *) NULL) {
1960 to = m->size;
1961 } else {
1962 to = search(v2, m->elts, m->size, 2, TRUE);
1963 if (to < m->size && cmp(v2, &m->elts[to]) == 0 &&
1964 (!T_INDEXED(v2->type) || v2->u.array == m->elts[to].u.array)) {
1965 /*
1966 * include last element
1967 */
1968 to += 2;
1969 }
1970 }
1971 if (from >= to) {
1972 return map_new(data, 0L); /* empty subrange */
1973 }
1974
1975 /* copy subrange */
1976 range = map_new(data, (long) (to -= from));
1977 i_copy(range->elts, m->elts + from, to);
1978
1979 d_ref_imports(range);
1980 return range;
1981 }
1982
1983 /*
1984 * NAME: mapping->indices()
1985 * DESCRIPTION: return the indices of a mapping
1986 */
1987 array *map_indices(data, m)
1988 dataspace *data;
1989 array *m;
1990 {
1991 register array *indices;
1992 register value *v1, *v2;
1993 register unsigned short n;
1994
1995 map_compact(data, m);
1996 indices = arr_new(data, (long) (n = m->size >> 1));
1997 v1 = indices->elts;
1998 for (v2 = m->elts; n > 0; v2 += 2, --n) {
1999 i_ref_value(v2);
2000 *v1++ = *v2;
2001 }
2002
2003 d_ref_imports(indices);
2004 return indices;
2005 }
2006
2007 /*
2008 * NAME: mapping->values()
2009 * DESCRIPTION: return the values of a mapping
2010 */
2011 array *map_values(data, m)
2012 dataspace *data;
2013 array *m;
2014 {
2015 register array *values;
2016 register value *v1, *v2;
2017 register unsigned short n;
2018
2019 map_compact(data, m);
2020 values = arr_new(data, (long) (n = m->size >> 1));
2021 v1 = values->elts;
2022 for (v2 = m->elts + 1; n > 0; v2 += 2, --n) {
2023 i_ref_value(v2);
2024 *v1++ = *v2;
2025 }
2026
2027 d_ref_imports(values);
2028 return values;
2029 }
2030
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.