ArchWizard

DGD/

source navigation ]
diff markup ]
identifier search ]
file search ]
Version: [ 1.0.a0 ] [ 1.1 ] [ 1.2 ] [ 1.2p1 ] [ 1.2p2 ] [ 1.2p3 ] [ 1.2p4 ] [ 1.2.151 ]

  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 

~ [ source navigation ] ~ [ diff markup ] ~ [ identifier search ] ~ [ file search ] ~

This page was automatically generated by the LXR engine.
Visit the LXR main site for more information.