1 /*---------------------------------------------------------------------------
2 * Array handling functions.
3 *
4 *---------------------------------------------------------------------------
5 * TODO: Rewrite the low-level functions (like allocate_array()) to return
6 * TODO:: failure codes (errno like) instead of throwing errors. In addition,
7 * TODO:: provide wrapper functions which do throw errorf()s, so that every
8 * TODO:: caller can handle the errors himself (like the swapper).
9 * The structure of an array ("vector") is defined in datatypes.h as this:
10 *
11 * vector_t_s {
12 * p_int size;
13 * p_int ref;
14 * p_int extra_ref; (ifdef DEBUG)
15 * wiz_list_t *user;
16 * svalue_t item[1...];
17 * };
18 *
19 * .size is the number of elements in the vector.
20 *
21 * .ref is the number of references to the vector. If this number
22 * reaches 0, the vector can (and should) be deallocated. This scheme
23 * breaks down with circular references, but those are caught by
24 * the garbage collector.
25 *
26 * .extra_ref exists when the driver is compiled for DEBUGging, and
27 * is used to countercheck the the .ref count.
28 *
29 * .user records which wizard's object created the vector, and is used
30 * to keep the wizlist statistics (array usage) up to date.
31 *
32 * .item[] is the array of elements in indexing order. The structure
33 * itself declares just an array of one element, it is task of the user
34 * to allocated a big enough memory block.
35 *
36 *
37 * Some macros help with the use of vector variables:
38 *
39 * VEC_SIZE(v): Return the number of elements in v.
40 *
41 * VEC_HEAD(size): Expand to the initializers of a vector with
42 * <size> elements and 1 ref. This does not include the
43 * element initialisers.
44 *
45 * LOCAL_VEC1(name, type1)
46 * LOCAL_VEC2(name, type1, type2)
47 * Construct a local vector instance named <name> with 1(2)
48 * elements of type <type1> (and <type2>). Both elements are
49 * initialised to 0, and the actual vector can be accessed
50 * as '<name>.v'.
51 *
52 * This module contains both low-level and efun-level functions.
53 * The latter are collected in the lower half of the source.
54 *---------------------------------------------------------------------------
55 */
56
57 #include "driver.h"
58 #include "typedefs.h"
59
60 #include "my-alloca.h"
61 #include <stddef.h>
62
63 #include "array.h"
64 #include "backend.h"
65 #include "closure.h" /* closure_cmp(), closure_eq() */
66 #include "interpret.h"
67 #include "main.h"
68 #include "mapping.h"
69 #include "mempools.h"
70 #include "mstrings.h"
71 #include "object.h"
72 #include "stdstrings.h"
73 #include "simulate.h"
74 #include "svalue.h"
75 #include "swap.h"
76 #include "wiz_list.h"
77 #include "xalloc.h"
78
79 #include "i-svalue_cmp.h"
80
81 /*-------------------------------------------------------------------------*/
82
83 #define ALLOC_VECTOR(nelem) \
84 ((size_t)nelem >= (SSIZE_MAX - sizeof(vector_t)) / sizeof(svalue_t)) \
85 ? NULL \
86 : (vector_t *)xalloc_pass(sizeof(vector_t) + \
87 sizeof(svalue_t) * (nelem - 1))
88
89 /* ALLOC_VECTOR(size,file,line): Allocate dynamically the memory for
90 * a vector of <size> elements.
91 * TODO: Use SIZET_MAX instead of SSIZE_MAX, see port.h
92 */
93
94 /*-------------------------------------------------------------------------*/
95
96 int num_arrays;
97 /* Total number of allocated arrays */
98
99 vector_t null_vector = { VEC_HEAD(0), { { T_INVALID } } };
100 /* The global empty array ({}).
101 * Reusing it is cheaper than repeated allocations/deallocations.
102 */
103
104 void (*allocate_array_error_handler) (const char *, ...)
105 = errorf; /* from simulate.c */
106 /* This handler is called if an allocation fails.
107 * Usually it points to simulate::errorf(), but the swapper
108 * replaces it temporarily with its own dummy handler when
109 * swapping in an object.
110 */
111
112 /*-------------------------------------------------------------------------*/
113 vector_t *
_allocate_array(mp_int n MTRACE_DECL)114 _allocate_array(mp_int n MTRACE_DECL)
115
116 /* Allocate an array for <n> elements (but not more than the current
117 * maximum) and return the pointer.
118 * The elements are initialised to the svalue 0.
119 *
120 * If the allocations fails (and errorf() does return), a 0 pointer
121 * may be returned. This is usually only possible when arrays
122 * are allocated from the swapper.
123 *
124 * Allocating an array of size 0 will return a reference to the
125 * globally shared empty array.
126 *
127 * If possible, annotate the allocations with <malloc_trace> and <...line>
128 */
129
130 {
131 mp_int i;
132 vector_t *p;
133 svalue_t *svp;
134
135 if (n < 0 || (max_array_size && (size_t)n > max_array_size))
136 errorf("Illegal array size: %"PRIdMPINT".\n", n);
137
138 if (n == 0) {
139 p = ref_array(&null_vector);
140 return p;
141 }
142
143 num_arrays++;
144
145 p = ALLOC_VECTOR(n);
146 if (!p) {
147 #ifndef MALLOC_TRACE
148 (*allocate_array_error_handler)
149 ("Out of memory: array[%"PRIdMPINT"]\n", n);
150 #else
151 (*allocate_array_error_handler)
152 ("(%s:%d) Out of memory: array[%"PRIdMPINT"]\n"
153 MTRACE_PASS, n);
154 #endif
155 return 0;
156 }
157
158 p->ref = 1;
159 p->size = n;
160 if (current_object)
161 (p->user = current_object->user)->size_array += n;
162 else
163 (p->user = &default_wizlist_entry)->size_array += n;
164
165 svp = p->item;
166 for (i = n; --i >= 0; )
167 *svp++ = const0;
168
169 return p;
170 }
171
172 /*-------------------------------------------------------------------------*/
173 vector_t *
_allocate_array_unlimited(mp_int n MTRACE_DECL)174 _allocate_array_unlimited(mp_int n MTRACE_DECL)
175
176 /* Allocate an array for <n> elements and return the pointer.
177 * The elements are initialised to the svalue 0.
178 *
179 * If the allocations fails (and errorf() does return), a 0 pointer
180 * may be returned. This is usually only possible when arrays
181 * are allocated from the swapper.
182 *
183 * Allocating an array of size 0 will return a reference to the
184 * globally shared empty array.
185 *
186 * If possible, annotate the allocations with <malloc_trace_file> and <...line>
187 */
188
189 {
190 mp_int i;
191 vector_t *p;
192 svalue_t *svp;
193
194 if (n < 0)
195 errorf("Illegal array size: %"PRIdMPINT".\n", n);
196
197 if (n == 0) {
198 p = ref_array(&null_vector);
199 return p;
200 }
201
202 num_arrays++;
203
204 p = ALLOC_VECTOR(n);
205 if (!p) {
206 #ifndef MALLOC_TRACE
207 (*allocate_array_error_handler)
208 ("Out of memory: unlimited array[%"PRIdMPINT"]\n", n);
209 #else
210 (*allocate_array_error_handler)
211 ("(%s:%d) Out of memory: unlimited array[%"PRIdMPINT"]\n"
212 MTRACE_PASS, n);
213 #endif
214 return 0;
215 }
216
217 p->ref = 1;
218 p->size = n;
219 if (current_object)
220 (p->user = current_object->user)->size_array += n;
221 else
222 (p->user = &default_wizlist_entry)->size_array += n;
223
224 svp = p->item;
225 for (i = n; --i >= 0; )
226 *svp++ = const0;
227
228 return p;
229 }
230
231 /*-------------------------------------------------------------------------*/
232 vector_t *
_allocate_uninit_array(mp_int n MTRACE_DECL)233 _allocate_uninit_array (mp_int n MTRACE_DECL)
234
235 /* Allocate an array for <n> elements (but no more than the current
236 * maximum) and return the pointer.
237 * The elements are not initialised.
238 * If the allocations fails (and errorf() does return), a 0 pointer
239 * may be returned.
240 *
241 * Allocating an array of size 0 will return a reference to the
242 * globally shared empty array.
243 *
244 * If possible, annotate the allocations with <malloc_trace_file> and <...line>
245 */
246
247 {
248 vector_t *p;
249
250 if (n < 0 || (max_array_size && (size_t)n > max_array_size))
251 errorf("Illegal array size: %"PRIdMPINT".\n", n);
252
253 if (n == 0) {
254 p = ref_array(&null_vector);
255 return p;
256 }
257
258 num_arrays++;
259
260 p = ALLOC_VECTOR(n);
261 if (!p) {
262 #ifndef MALLOC_TRACE
263 (*allocate_array_error_handler)
264 ("Out of memory: uninited array[%"PRIdMPINT"]\n", n);
265 #else
266 (*allocate_array_error_handler)
267 ("(%s:%d) Out of memory: uninited array[%"PRIdMPINT"]\n"
268 MTRACE_PASS, n);
269 #endif
270 return 0;
271 }
272
273 p->ref = 1;
274 p->size = n;
275 if (current_object)
276 (p->user = current_object->user)->size_array += n;
277 else
278 (p->user = &default_wizlist_entry)->size_array += n;
279
280 return p;
281 }
282
283 /*-------------------------------------------------------------------------*/
284 void
_free_vector(vector_t * p)285 _free_vector (vector_t *p)
286
287 /* Deallocate the vector <p>, properly freeing the contained elements.
288 * The refcount is supposed to be zero at the time of call.
289 */
290
291 {
292 mp_uint i;
293 svalue_t *svp;
294
295 #ifdef DEBUG
296 if (p->ref > 0)
297 fatal("Vector with %"PRIdPINT" refs passed to _free_vector()\n",
298 p->ref);
299 if (p == &null_vector)
300 fatal("Tried to free the zero-size shared vector.\n");
301 #endif
302
303 i = VEC_SIZE(p);
304
305 num_arrays--;
306 p->user->size_array -= i;
307
308 svp = p->item;
309 do {
310 free_svalue(svp++);
311 } while (--i);
312
313 xfree(p);
314 } /* _free_vector() */
315
316 /*-------------------------------------------------------------------------*/
317 void
free_empty_vector(vector_t * p)318 free_empty_vector (vector_t *p)
319
320 /* Deallocate the vector <p> without regard of refcount or contained
321 * elements. Just the statistics are cared for.
322 */
323
324 {
325 mp_uint i;
326
327 i = VEC_SIZE(p);
328 p->user->size_array -= i;
329 num_arrays--;
330 xfree((char *)p);
331 }
332
333 /*-------------------------------------------------------------------------*/
334 #ifdef USE_ALISTS
335 static INLINE vector_t *
i_shrink_array(vector_t * p,mp_int n)336 i_shrink_array (vector_t *p, mp_int n)
337
338 /* Create and return a new array containing just the first <n> elements
339 * of <p>. <p> itself is freed (and thus possibly deallocated).
340 * This function is only needed if alists are used.
341 */
342
343 {
344 vector_t *res;
345
346 if (p->ref == 1 && VEC_SIZE(p) == n)
347 return p;
348 /* This case seems to happen often enough to justify
349 * the shortcut
350 */
351
352 if (n)
353 {
354 res = slice_array(p, 0, n-1);
355 }
356 else
357 {
358 res = ref_array(&null_vector);
359 }
360 free_array(p);
361 return res;
362 }
363
shrink_array(vector_t * p,mp_int n)364 vector_t * shrink_array (vector_t *p, mp_int n) { return i_shrink_array(p, n); }
365
366 #define shrink_array(p,n) i_shrink_array(p,n)
367 #endif
368
369 /*-------------------------------------------------------------------------*/
370 void
set_vector_user(vector_t * p,object_t * owner)371 set_vector_user (vector_t *p, object_t *owner)
372
373 /* Wizlist statistics: take vector <p> from its former owner and account it
374 * under its new <owner>.
375 */
376
377 {
378 svalue_t *svp;
379 mp_int i;
380
381 i = (mp_int)VEC_SIZE(p);
382 if (p->user)
383 p->user->size_array -= i;
384 if ( NULL != (p->user = owner->user) )
385 p->user->size_array += i;
386 svp = p->item;
387 for (; --i >= 0; svp++) {
388 set_svalue_user(svp, owner);
389 }
390 }
391
392 /*-------------------------------------------------------------------------*/
393 void
check_for_destr(vector_t * v)394 check_for_destr (vector_t *v)
395
396 /* Check the vector <v> for destructed objects and closures on destructed
397 * objects and replace them with svalue 0s. Subvectors are not checked,
398 * though.
399 *
400 * This function is used by certain efuns (parse_command(), unique_array(),
401 * map_array()) to make sure that the data passed to the efuns is valid,
402 * avoiding game crashes (though this won't happen on simple operations
403 * like assign_svalue).
404 * TODO: The better way is to make the affected efuns resistant against
405 * TODO:: destructed objects, and keeping this only as a safeguard and
406 * TODO:: to save memory.
407 */
408
409 {
410 mp_int i;
411 svalue_t *p;
412
413 for (p = v->item, i = (mp_int)VEC_SIZE(v); --i >= 0 ; p++ )
414 {
415 if (destructed_object_ref(p))
416 assign_svalue(p, &const0);
417 }
418 } /* check_for_destr() */
419
420 /*-------------------------------------------------------------------------*/
421 long
total_array_size(void)422 total_array_size (void)
423
424 /* Statistics for the command 'status [tables]'.
425 * Return the total memory used for all vectors in the game.
426 */
427
428 {
429 wiz_list_t *wl;
430 long total;
431
432 total = default_wizlist_entry.size_array;
433 for (wl = all_wiz; wl; wl = wl->next)
434 total += wl->size_array;
435 total *= sizeof(svalue_t);
436 total += num_arrays * (sizeof(vector_t) - sizeof(svalue_t));
437 return total;
438 }
439
440 /*-------------------------------------------------------------------------*/
441 #if defined(GC_SUPPORT)
442
443 void
clear_array_size(void)444 clear_array_size (void)
445
446 /* Clear the statistics about the number and memory usage of all vectors
447 * in the game.
448 */
449
450 {
451 wiz_list_t *wl;
452
453 num_arrays = 0;
454 default_wizlist_entry.size_array = 0;
455 for (wl = all_wiz; wl; wl = wl->next)
456 wl->size_array = 0;
457 } /* clear_array_size(void) */
458
459
460 /*-------------------------------------------------------------------------*/
461 void
count_array_size(vector_t * vec)462 count_array_size (vector_t *vec)
463
464 /* Add the vector <vec> to the statistics.
465 */
466
467 {
468 num_arrays++;
469 vec->user->size_array += VEC_SIZE(vec);
470 } /* count_array_size(void) */
471
472 #endif /* GC_SUPPORT */
473
474 /*-------------------------------------------------------------------------*/
475 vector_t *
explode_string(string_t * str,string_t * del)476 explode_string (string_t *str, string_t *del)
477
478 /* Explode the string <str> by delimiter string <del> and return an array
479 * of the (unshared) strings found between the delimiters.
480 * They are unshared because they are most likely short-lived.
481 *
482 * TODO: At some later point in the execution thread, all the longlived
483 * unshared strings should maybe be converted into shared strings.
484 *
485 * This is the new, logical behaviour: nothing is assumed.
486 * The relation implode(explode(x,y),y) == x holds.
487 *
488 * explode("xyz", "") -> { "x", "y", "z" }
489 * explode("###", "##") -> { "", "#" }
490 * explode(" the fox ", " ") -> { "", "the", "", "", "fox", ""}
491 */
492
493 {
494 char *p, *beg;
495 long num;
496 long len, left;
497 vector_t *ret;
498 string_t *buff;
499
500 len = (long)mstrsize(del);
501
502 /* --- Special case: Delimiter is an empty or one-char string --- */
503 if (len <= 1) {
504
505 /* Delimiter is empty: return an array which holds all characters as
506 * single-character strings.
507 */
508 if (len < 1) {
509 svalue_t *svp;
510
511 len = (long)mstrsize(str);
512 ret = allocate_array(len);
513 for ( svp = ret->item, p = get_txt(str)
514 ; --len >= 0
515 ; svp++, p++ ) {
516 buff = new_n_mstring(p, 1);
517 if (!buff) {
518 free_array(ret);
519 outofmem(1, "explode() on a string");
520 }
521 put_string(svp, buff);
522 }
523 return ret;
524
525 }
526
527 /* Delimiter is one-char string: speedy implementation which uses
528 * direct character comparisons instead of calls to memcmp().
529 */
530 else {
531 char c;
532 char * txt;
533 svalue_t *svp;
534
535 txt = get_txt(str);
536 len = (long)mstrsize(str);
537 c = get_txt(del)[0];
538
539 /* TODO: Remember positions here */
540 /* Determine the number of delimiters in the string. */
541 for (num = 1, p = txt
542 ; p < txt + len && NULL != (p = memchr(p, c, len - (p - txt)))
543 ; p++, num++) NOOP;
544
545 ret = allocate_array(num);
546 for ( svp = ret->item, left = len
547 ; NULL != (p = memchr(txt, c, left))
548 ; left -= (p + 1 - txt), txt = p + 1, svp++)
549 {
550 len = p - txt;
551 buff = new_n_mstring(txt, (size_t)len);
552 if (!buff) {
553 free_array(ret);
554 outofmem(len, "explode() on a string");
555 }
556 put_string(svp, buff);
557 }
558
559 /* txt now points to the (possibly empty) remains after
560 * the last delimiter.
561 */
562 len = get_txt(str) + mstrsize(str) - txt;
563 buff = new_n_mstring(txt, (size_t)len);
564 if (!buff) {
565 free_array(ret);
566 outofmem(len, "explode() on a string");
567 }
568 put_string(svp, buff);
569
570 return ret;
571 }
572
573 /* NOTREACHED */
574 } /* --- End of special case --- */
575
576 /* Find the number of occurences of the delimiter 'del' by doing
577 * a first scan of the string.
578 *
579 * The number of array items is then one more than the number of
580 * delimiters, hence the 'num=1'.
581 * TODO: Implement a strncmp() which returns the number of matching
582 * characters in case of a mismatch.
583 * TODO: Remember the found positions so that we don't have to
584 * do the comparisons again.
585 */
586 for (p = get_txt(str), left = mstrsize(str), num=1 ; left > 0; )
587 {
588 if (left >= len && memcmp(p, get_txt(del), (size_t)len) == 0) {
589 p += len;
590 left -= len;
591 num++;
592 }
593 else
594 {
595 p += 1;
596 left -= 1;
597 }
598 }
599
600 ret = allocate_array(num);
601
602 /* Extract the <num> strings into the result array <ret>.
603 * <buff> serves as temporary buffer for the copying.
604 */
605 for (p = get_txt(str), beg = get_txt(str), num = 0, left = mstrsize(str)
606 ; left > 0; )
607 {
608 if (left >= len && memcmp(p, get_txt(del), (size_t)len) == 0)
609 {
610 ptrdiff_t bufflen;
611
612 bufflen = p - beg;
613 buff = new_n_mstring(beg, (size_t)bufflen);
614 if (!buff) {
615 free_array(ret);
616 outofmem(bufflen, "buffer for explode()");
617 }
618
619 put_string(ret->item+num, buff);
620
621 num++;
622 beg = p + len;
623 p = beg;
624 left -= len;
625
626 } else {
627 p += 1;
628 left -= 1;
629 }
630 }
631
632 /* Copy the last occurence (may be empty). */
633 len = get_txt(str) + mstrsize(str) - beg;
634 buff = new_n_mstring(beg, (size_t)len);
635 if (!buff) {
636 free_array(ret);
637 outofmem(len, "last fragment in explode()");
638 }
639 put_string(ret->item + num, buff);
640
641 return ret;
642 } /* explode_string() */
643
644 /*-------------------------------------------------------------------------*/
645 string_t *
arr_implode_string(vector_t * arr,string_t * del MTRACE_DECL)646 arr_implode_string (vector_t *arr, string_t *del MTRACE_DECL)
647
648 /* Implode the string vector <arr> by <del>, i.e. all strings from <arr>
649 * with <del> interspersed are contatenated into one string. The
650 * resulting string is returned. The function will return at least
651 * the empty string "".
652 *
653 * Non-string elements are ignore; elements referencing destructed
654 * objects are replaced by the svalue number 0.
655 *
656 * implode({"The", "fox", ""}, " ") -> "The fox "
657 *
658 * If possible, annotate the allocations with <file> and <line>
659 */
660
661 {
662 mp_int size, i, arr_size;
663 size_t del_len;
664 char *deltxt;
665 char *p;
666 string_t *result;
667 svalue_t *svp;
668
669 del_len = mstrsize(del);
670 deltxt = get_txt(del);
671
672 /* Compute the <size> of the final string
673 */
674 size = -(mp_int)del_len;
675 for (i = (arr_size = (mp_int)VEC_SIZE(arr)), svp = arr->item; --i >= 0; svp++)
676 {
677 if (svp->type == T_STRING) {
678 size += (mp_int)del_len + mstrsize(svp->u.str);
679 }
680 else if (destructed_object_ref(svp))
681 {
682 /* While we're here anyway... */
683 assign_svalue(svp, &const0);
684 }
685 }
686
687 /* Allocate the string; cop out if there's nothing to implode.
688 */
689 if (size <= 0)
690 return ref_mstring(STR_EMPTY);
691
692 result = mstring_alloc_string(size MTRACE_PASS);
693 if (!result)
694 {
695 /* caller raises the errorf() */
696 return NULL;
697 }
698 p = get_txt(result);
699
700 /* Concatenate the result string.
701 *
702 * <i> is the number of elements left to check,
703 * <svp> is the next element to check,
704 * <p> points to the current end of the result string.
705 */
706
707 svp = arr->item;
708
709 /* Look for the first element to add (there is at least one!) */
710 for (i = arr_size; svp->type != T_STRING; )
711 {
712 --i;
713 svp++;
714 }
715
716 memcpy(p, get_txt(svp->u.str), mstrsize(svp->u.str));
717 p += mstrsize(svp->u.str);
718
719 /* Copy the others if any */
720 while (--i > 0)
721 {
722 svp++;
723 if (svp->type == T_STRING)
724 {
725 memcpy(p, deltxt, del_len);
726 p += del_len;
727 memcpy(p, get_txt(svp->u.str), mstrsize(svp->u.str));
728 p += mstrsize(svp->u.str);
729 }
730 }
731
732 return result;
733 } /* implode_array() */
734
735 /*-------------------------------------------------------------------------*/
736 vector_t *
slice_array(vector_t * p,mp_int from,mp_int to)737 slice_array (vector_t *p, mp_int from, mp_int to)
738
739 /* Create a vector slice from vector <p>, range <from> to <to> inclusive,
740 * and return it.
741 *
742 * <to> is guaranteed to not exceed the size of <p>.
743 * If <from> is greater than <to>, the empty array is returned.
744 */
745
746 {
747 vector_t *d;
748 int cnt;
749
750 if (from < 0)
751 from = 0;
752
753 if (to < from)
754 return allocate_array(0);
755
756 d = allocate_array(to-from+1);
757 for (cnt = from; cnt <= to; cnt++)
758 assign_svalue_no_free(&d->item[cnt-from], &p->item[cnt]);
759
760 return d;
761 }
762
763 /*-------------------------------------------------------------------------*/
764 vector_t *
add_array(vector_t * p,vector_t * q)765 add_array (vector_t *p, vector_t *q)
766
767 /* Concatenate the vectors <p> and <q> and return the resulting vector.
768 * <p> and <q> are not modified.
769 */
770
771 {
772 mp_int cnt;
773 svalue_t *s, *d;
774 mp_int q_size;
775
776 s = p->item;
777 p = allocate_array((cnt = (mp_int)VEC_SIZE(p)) + (q_size = (mp_int)VEC_SIZE(q)));
778 d = p->item;
779 for ( ; --cnt >= 0; ) {
780 assign_svalue_no_free (d++, s++);
781 }
782 s = q->item;
783 for (cnt = q_size; --cnt >= 0; ) {
784 assign_svalue_no_free (d++, s++);
785 }
786 return p;
787 } /* add_array() */
788
789 /*-------------------------------------------------------------------------*/
790 static INLINE void
sanitize_array(vector_t * vec)791 sanitize_array (vector_t * vec)
792
793 /* In the given array, make all strings tabled, and replace destructed
794 * object references by svalue 0s.
795 * Used for example in preparation for ordering the array.
796 */
797
798 {
799 size_t j, keynum;
800 svalue_t * inpnt;
801
802 keynum = VEC_SIZE(vec);
803 for ( j = 0, inpnt = vec->item; j < keynum; j++, inpnt++)
804 {
805 if (inpnt->type == T_STRING)
806 {
807 if (!mstr_tabled(inpnt->u.str))
808 {
809 inpnt->u.str = make_tabled(inpnt->u.str);
810 }
811 }
812 else if (destructed_object_ref(inpnt))
813 {
814 free_svalue(inpnt);
815 put_number(inpnt, 0);
816 }
817 }
818 } /* sanitize_array() */
819
820 /*-------------------------------------------------------------------------*/
821 ptrdiff_t *
get_array_order(vector_t * vec)822 get_array_order (vector_t * vec )
823
824 /* Determine the order of the elements in vector <vec> and return the
825 * sorted indices (actually svalue_t* pointer diffs). The order is
826 * determined by svalue_cmp() (which happens to be high-to-low).
827 *
828 * As a side effect, strings in the vector are made shared, and
829 * destructed objects in the vector are replaced by svalue 0s.
830 */
831
832 {
833 ptrdiff_t * sorted;
834 /* The vector elements in sorted order, given as the offsets of the array
835 * element in question to the start of the vector. This way,
836 * sorted[] needs only to be <keynum> elements long.
837 * sorted[] is created from root[] after sorting.
838 */
839
840 svalue_t **root;
841 /* Auxiliary array with the sorted keys as svalue* into vec.
842 * This way the sorting is given by the order of the pointers, while
843 * the original position is given by (pointer - vec->item).
844 * The very first element is a dummy (heapsort uses array indexing
845 * starting with index 1), the next <keynum> elements are scratch
846 * area, the final <keynum> elements hold the sorted keys in reverse
847 * order.
848 */
849 svalue_t **root2; /* Aux pointer into *root. */
850 svalue_t *inpnt; /* Pointer to the value to copy into the result */
851 mp_int keynum; /* Number of keys */
852 int j;
853
854 keynum = (mp_int)VEC_SIZE(vec);
855
856 xallocate(sorted, keynum * sizeof(ptrdiff_t) + sizeof(ptrdiff_t)
857 , "sorted index array");
858 /* The extra sizeof(ptrdiff_t) is just to have something in
859 * case keynum is 0.
860 */
861
862 sanitize_array(vec);
863
864 /* For small arrays, use something else but Heapsort - trading
865 * less overhead for worse complexity.
866 * TODO: The limit of '6' is arbitrary (it was the transition point
867 * TODO:: on my machine) - a better way would be to test the system
868 * TODO:: speed at startup.
869 */
870 if (keynum <= 6)
871 {
872 switch (keynum)
873 {
874 case 0:
875 /* Do nothing */
876 break;
877
878 case 1:
879 sorted[0] = 0;
880 break;
881
882 case 2:
883 if (svalue_cmp(vec->item, vec->item + 1) > 0)
884 {
885 sorted[0] = 0;
886 sorted[1] = 1;
887 }
888 else
889 {
890 sorted[0] = 1;
891 sorted[1] = 0;
892 }
893 break;
894
895 case 3:
896 {
897 int d;
898
899 sorted[0] = 0;
900 sorted[1] = 1;
901 sorted[2] = 2;
902 d = svalue_cmp(vec->item, vec->item + 1);
903 if (d < 0)
904 {
905 sorted[1] = 0;
906 sorted[0] = 1;
907 }
908 d = svalue_cmp(vec->item + sorted[0], vec->item + 2);
909 if (d < 0)
910 {
911 ptrdiff_t tmp = sorted[2];
912 sorted[2] = sorted[0];
913 sorted[0] = tmp;
914 }
915 d = svalue_cmp(vec->item + sorted[1], vec->item + sorted[2]);
916 if (d < 0)
917 {
918 ptrdiff_t tmp = sorted[2];
919 sorted[2] = sorted[1];
920 sorted[1] = tmp;
921 }
922 break;
923 } /* case 3 */
924
925 default:
926 {
927 size_t start; /* Index of the next position to set */
928
929 /* Initialise the sorted[] array */
930 for (start = 0; (mp_int)start < keynum; start++)
931 sorted[start] = (ptrdiff_t)start;
932
933 /* Outer loop: walk start through the array, being the position
934 * where the next highest element has to go.
935 */
936 for (start = 0; (mp_int)start < keynum-1; start++)
937 {
938 size_t max_idx; /* Index (in sorted[]) of the current max */
939 svalue_t *max; /* Pointer to the current max svalue */
940 size_t test_idx; /* Index of element to test */
941
942 /* Find the highest element in the remaining vector */
943 max_idx = start;
944 max = vec->item + sorted[start];
945
946 for (test_idx = start+1; (mp_int)test_idx < keynum; test_idx++)
947 {
948 svalue_t *test = vec->item + sorted[test_idx];
949
950 if (svalue_cmp(max, test) < 0)
951 {
952 max_idx = test_idx;
953 max = test;
954 }
955 }
956
957 /* Put the found maximum at position start */
958 if (max_idx != start)
959 {
960 ptrdiff_t tmp = sorted[max_idx];
961 sorted[max_idx] = sorted[start];
962 sorted[start] = tmp;
963 }
964 }
965 break;
966 } /* case default */
967 } /* switch(keynum) */
968
969 return sorted;
970 }
971
972 /* Allocate the auxiliary array. */
973 root = (svalue_t **)alloca(keynum * sizeof(svalue_t *[2])
974 + sizeof(svalue_t)
975 );
976 if (!root)
977 {
978 errorf("Stack overflow in get_array_order()");
979 /* NOTREACHED */
980 return NULL;
981 }
982
983 /* Heapsort vec into *root.
984 */
985
986 /* Heapify the keys into the first half of root */
987 for ( j = 1, inpnt = vec->item
988 ; j <= keynum
989 ; j++, inpnt++)
990 {
991 int curix, parix;
992
993 /* propagate the new element up in the heap as much as necessary */
994 for (curix = j; 0 != (parix = curix>>1); ) {
995 if ( svalue_cmp(root[parix], inpnt) > 0 ) {
996 root[curix] = root[parix];
997 curix = parix;
998 } else {
999 break;
1000 }
1001 }
1002 root[curix] = inpnt;
1003 }
1004
1005 root++; /* Adjust root to ignore the heapsort-dummy element */
1006
1007 /* Sort the heaped keys from the first into the second half of root. */
1008 root2 = &root[keynum];
1009 for(j = keynum; --j >= 0; ) {
1010 int curix;
1011
1012 *root2++ = *root;
1013 for (curix=0; ; ) {
1014 int child, child2;
1015
1016 child = curix+curix+1;
1017 child2 = child+1;
1018 if (child2 >= keynum) {
1019 if (child2 == keynum && root[child]) {
1020 root[curix] = root[child];
1021 curix = child;
1022 }
1023 break;
1024 }
1025 if (root[child2]) {
1026 if (!root[child] || svalue_cmp(root[child], root[child2]) > 0)
1027 {
1028 root[curix] = root[child2];
1029 curix = child2;
1030 continue;
1031 }
1032 } else if (!root[child]) {
1033 break;
1034 }
1035 root[curix] = root[child];
1036 curix = child;
1037 }
1038 root[curix] = 0;
1039 }
1040
1041 /* Compute the sorted offsets from root[] into sorted[].
1042 * Note that root[] is in reverse order.
1043 */
1044 for (root = &root[keynum], j = 0; j < keynum; j++)
1045 sorted[j] = root[keynum-j-1] - vec->item;
1046
1047 return sorted;
1048 } /* get_array_order() */
1049
1050 /*-------------------------------------------------------------------------*/
1051 vector_t *
order_array(vector_t * vec)1052 order_array (vector_t *vec)
1053
1054 /* Order the array <vec> and return a new vector with the sorted data.
1055 * The sorting order is the internal order defined by svalue_cmp() (which
1056 * happens to be high-to-low).
1057 *
1058 * This function and lookup_key() are used in several places for internal
1059 * lookup functions (e.g. in say()).
1060 *
1061 * As a side effect, strings in the vector are made shared, and
1062 * destructed objects in the vector are replaced by svalue 0s.
1063 */
1064
1065 {
1066 vector_t * out; /* The result vector of vectors */
1067 svalue_t * outpnt; /* Next result value element to fill in */
1068 ptrdiff_t * sorted; /* The vector elements in sorted order */
1069 long keynum; /* Number of keys */
1070 long j;
1071
1072 keynum = (long)VEC_SIZE(vec);
1073
1074 sorted = get_array_order(vec);
1075
1076 /* Copy the elements from the in-vector to the result vector.
1077 */
1078 out = allocate_array(VEC_SIZE(vec));
1079 outpnt = out->item;
1080 for (j = keynum; --j >= 0; )
1081 {
1082 assign_svalue_no_free(outpnt++, vec->item + sorted[j]);
1083 }
1084
1085 xfree(sorted);
1086
1087 return out;
1088 } /* order_array() */
1089
1090 /*-------------------------------------------------------------------------*/
1091 long
lookup_key(svalue_t * key,vector_t * vec)1092 lookup_key (svalue_t *key, vector_t *vec)
1093
1094 /* Lookup up value <key> in ordered vector <vec> and return it's position.
1095 * If not found, return as negative number the position at which the
1096 * key would have to be inserted, incremented by 1. That is:
1097 * -1 -> key should be at position 0,
1098 * -2 -> key should be at position 1,
1099 * -len(vec)-1 -> key should be appended to the vector.
1100 *
1101 * <vec> must be sorted according to svalue_cmp(), else the result will be
1102 * interesting, but useless.
1103 *
1104 * The function is used by object.c and pkg-alists.c .
1105 */
1106
1107 {
1108 mp_int i, o, d, keynum;
1109 svalue_t shared_string_key;
1110 /* The svalue used to shared search key during the search.
1111 * It does not count as reference!
1112 */
1113
1114 /* If key is a non-shared string, lookup and use the shared copy.
1115 */
1116 if (key->type == T_STRING && !mstr_tabled(key->u.str))
1117 {
1118 shared_string_key.type = T_STRING;
1119 if ( !(shared_string_key.u.str = find_tabled(key->u.str)) )
1120 {
1121 return -1;
1122 }
1123 key = &shared_string_key;
1124 }
1125
1126 if ( !(keynum = (mp_int)VEC_SIZE(vec)) )
1127 return -1;
1128
1129 /* Simple binary search */
1130
1131 i = keynum >> 1;
1132 o = (i+2) >> 1;
1133 for (;;) {
1134 d = svalue_cmp(key, &vec->item[i]);
1135 if (d < 0)
1136 {
1137 i -= o;
1138 if (i < 0)
1139 {
1140 i = 0;
1141 }
1142 }
1143 else if (d > 0)
1144 {
1145 i += o;
1146 if (i >= keynum)
1147 {
1148 i = keynum-1;
1149 }
1150 }
1151 else
1152 {
1153 /* Found! */
1154 return i;
1155 }
1156
1157 if (o <= 1)
1158 {
1159 /* Last element to try */
1160 d = svalue_cmp(key, &vec->item[i]);
1161 if (d == 0) return i;
1162 if (d > 0) return -(i+1)-1;
1163 return -i-1;
1164 }
1165 o = (o+1) >> 1;
1166 }
1167
1168 /* NOTREACHED */
1169 return -1;
1170 } /* lookup_key() */
1171
1172 /*-------------------------------------------------------------------------*/
1173 static Bool *
match_arrays(vector_t * vec1,vector_t * vec2)1174 match_arrays (vector_t *vec1, vector_t *vec2)
1175
1176 /* Compare the contents of the two (unordered) vectors <vec1> and
1177 * <vec2> and return a boolean vector describing for each vector
1178 * which elements are in both.
1179 *
1180 * The resulting bool vector has len(vec1)+len(vec2) flags (but
1181 * at least 1); the first describing the elements of vec1, the last
1182 * describing those of vec2. Each flag is FALSE if the vector entry
1183 * is unique, and TRUE if the same value appears in the other vector.
1184 *
1185 * When out of memory, an errorf() is thrown.
1186 */
1187
1188 {
1189 size_t len1, len2, len; /* Length of vec1, vec2, and both summed */
1190 Bool *flags; /* The resulting flag vector */
1191
1192 len1 = VEC_SIZE(vec1);
1193 len2 = VEC_SIZE(vec2);
1194
1195 /* Get the flag vector, default it to 'non matching'. */
1196 len = len1 + len2; if (!len) len = 1;
1197 xallocate(flags, len * sizeof(Bool), "flag vector");
1198 memset(flags, 0, len * sizeof(Bool));
1199
1200 /* Test some special cases */
1201
1202 /* Special case: if one of the vectors is empty, no elements match */
1203 if (len1 == 0 || len2 == 0)
1204 return flags;
1205
1206 /* Special case: if one of the vectors has only one element,
1207 * a simple linear comparison is sufficient.
1208 */
1209 if (len1 == 1 || len2 == 1)
1210 {
1211 svalue_t * rover; /* Pointer to the long vector elements */
1212 size_t rlen; /* Length (remaining) in the long vector */
1213 svalue_t * elem; /* Pointer to the single-elem vector elements */
1214 Bool * rflag; /* Pointer to the long vector flags */
1215 Bool * eflag; /* Pointer to the single-elem vector flag */
1216
1217 sanitize_array(vec1);
1218 sanitize_array(vec2);
1219
1220 /* Sort out which vector is which */
1221 if (len1 == 1)
1222 {
1223 /* Even more special case: both vectors have just one elem */
1224 if (len2 == 1)
1225 {
1226 if (!svalue_eq(vec1->item, vec2->item))
1227 {
1228 flags[0] = flags[1] = MY_TRUE;
1229 }
1230 return flags;
1231 }
1232
1233 /* vec1 is the short one */
1234 rover = vec2->item;
1235 rlen = len2;
1236 rflag = flags + len1;
1237 elem = vec1->item;
1238 eflag = flags;
1239 }
1240 else /* len2 == 1 */
1241 {
1242 /* vec2 is the short one */
1243 rover = vec1->item;
1244 rlen = len1;
1245 rflag = flags;
1246 elem = vec2->item;
1247 eflag = flags + len1;
1248 }
1249
1250 /* Now loop over all elements in the long vector and compare
1251 * them to the one in the short vector.
1252 */
1253 for ( ; rlen != 0; rlen--, rover++, rflag++)
1254 {
1255 if (!svalue_eq(rover, elem))
1256 *rflag = *eflag = MY_TRUE;
1257 }
1258
1259 /* Done */
1260 return flags;
1261 } /* if (one vector has only one element */
1262
1263 /* The generic matching routine: first both arrays are ordered,
1264 * then compared side by side.
1265 */
1266 {
1267 ptrdiff_t *sorted1, *sorted2; /* Ordered indices to the vectors */
1268 ptrdiff_t *index1, *index2; /* Current elements to compare */
1269 Bool *flag1, *flag2; /* flags base pointers */
1270
1271 sorted1 = get_array_order(vec1);
1272 sorted2 = get_array_order(vec2);
1273
1274 /* Set up the comparison */
1275 index1 = sorted1;
1276 index2 = sorted2;
1277 flag1 = flags;
1278 flag2 = flags + len1;
1279
1280 /* Compare side by side. Any element left uncompared at
1281 * the end is automatically non-matching.
1282 */
1283 while (len1 != 0 && len2 != 0)
1284 {
1285 int d;
1286
1287 d = svalue_cmp(vec1->item + *index1, vec2->item + *index2);
1288 if (d == 0)
1289 {
1290 /* Elements match */
1291 svalue_t *test_val = vec1->item+*index1;
1292
1293 /* Important here is to remember that there might
1294 * be several elements of the same value in a row.
1295 * The side-by-side comparison itself is not able
1296 * to handle it, so we have to check here manually
1297 * for it.
1298 * The loops will leave index1/index2 point to the
1299 * first element after the sequence of matching ones.
1300 */
1301 do {
1302 flag1[*index1] = MY_TRUE;
1303 index1++;
1304 len1--;
1305 if (len1 != 0)
1306 d = svalue_eq(test_val, vec1->item + *index1);
1307 }
1308 while (len1 != 0 && d == 0);
1309
1310 do {
1311 flag2[*index2] = MY_TRUE;
1312 index2++;
1313 len2--;
1314 if (len2 != 0)
1315 d = svalue_eq(test_val, vec2->item + *index2);
1316 }
1317 while (len2 != 0 && d == 0);
1318
1319 continue; /* Next iteration of the main loop */
1320 }
1321
1322 /* Else advance in array(s) */
1323 if (d > 0)
1324 {
1325 index1++;
1326 len1--;
1327 }
1328
1329 if (d < 0)
1330 {
1331 index2++;
1332 len2--;
1333 }
1334 } /* while (in both vectors) */
1335
1336 /* Cleanup */
1337 xfree(sorted1);
1338 xfree(sorted2);
1339
1340 /* Done */
1341 return flags;
1342 }
1343
1344 /* NOTREACHED */
1345 return flags;
1346
1347 } /* match_array() */
1348
1349 /*-------------------------------------------------------------------------*/
1350 vector_t *
subtract_array(vector_t * minuend,vector_t * subtrahend)1351 subtract_array (vector_t *minuend, vector_t *subtrahend)
1352
1353 /* Subtract all elements in <subtrahend> from the vector <minuend>
1354 * and return the resulting difference vector.
1355 * <subtrahend> and <minuend> are freed.
1356 */
1357
1358 {
1359 Bool *flags; /* The result from match_arrays() */
1360 size_t result_size; /* Size of the result array */
1361 vector_t *result; /* Result array */
1362 svalue_t *dest; /* Pointer for storing the result elements */
1363 size_t i;
1364
1365 size_t minuend_size = VEC_SIZE(minuend);
1366 size_t subtrahend_size = VEC_SIZE(subtrahend);
1367
1368 /* Handle empty vectors quickly */
1369
1370 if (minuend_size == 0 || subtrahend_size == 0)
1371 {
1372 free_array(subtrahend);
1373 return minuend;
1374 }
1375
1376 /* Non-trivial arrays: match them up */
1377 flags = match_arrays(minuend, subtrahend);
1378
1379 /* Count how many elements would be left in minuend
1380 * and allocate the result array.
1381 */
1382 for (i = result_size = 0; i < minuend_size; i++)
1383 {
1384 if (!flags[i])
1385 result_size++;
1386 }
1387
1388 if (result_size == minuend_size)
1389 {
1390 /* No elements to remove */
1391 xfree(flags);
1392 free_array(subtrahend);
1393 return minuend;
1394 }
1395
1396 if (max_array_size && result_size > max_array_size)
1397 {
1398 xfree(flags);
1399 free_array(minuend);
1400 free_array(subtrahend);
1401 errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
1402 }
1403
1404 result = allocate_array(result_size);
1405
1406 /* Copy the elements to keep from minuend into result.
1407 * We count down result_size to be able to stop as early
1408 * as possible.
1409 */
1410 for ( dest = result->item, i = 0
1411 ; i < minuend_size && result_size != 0
1412 ; i++
1413 )
1414 {
1415 if (!flags[i])
1416 {
1417 assign_svalue_no_free(dest, minuend->item+i);
1418 dest++;
1419 result_size--;
1420 }
1421 }
1422
1423 /* Cleanup and return */
1424 xfree(flags);
1425 free_array(minuend);
1426 free_array(subtrahend);
1427
1428 return result;
1429 } /* subtract_array() */
1430
1431 /*-------------------------------------------------------------------------*/
1432 vector_t *
intersect_array(vector_t * vec1,vector_t * vec2)1433 intersect_array (vector_t *vec1, vector_t *vec2)
1434
1435 /* OPERATOR & (array intersection)
1436 *
1437 * Perform an intersection of the two vectors <vec1> and <vec2>.
1438 * The result is a new vector with all elements which are present in both
1439 * input vectors.
1440 *
1441 * Both <vec1> and <vec2> are freed.
1442 */
1443
1444 {
1445 Bool *flags; /* The result from match_arrays() */
1446 size_t result_size; /* Size of the result array */
1447 vector_t *result; /* Result array */
1448 svalue_t *dest; /* Pointer for storing the result elements */
1449 size_t i;
1450
1451 size_t vec1_size = VEC_SIZE(vec1);
1452 size_t vec2_size = VEC_SIZE(vec2);
1453
1454 /* Handle empty arrays quickly */
1455
1456 if (vec1_size == 0 || vec2_size == 0)
1457 {
1458 free_array(vec2);
1459 free_array(vec1);
1460 return ref_array(&null_vector);
1461 }
1462
1463 /* Non-trivial arrays: match them up */
1464 flags = match_arrays(vec1, vec2);
1465
1466 /* Count how many elements have to be copied from vec1
1467 * and allocate the result array.
1468 */
1469 for (i = result_size = 0; i < vec1_size; i++)
1470 {
1471 if (flags[i])
1472 result_size++;
1473 }
1474
1475 if (result_size == vec1_size)
1476 {
1477 /* No elements to remove */
1478 xfree(flags);
1479 free_array(vec2);
1480 return vec1;
1481 }
1482
1483 if (max_array_size && result_size > max_array_size)
1484 {
1485 xfree(flags);
1486 free_array(vec1);
1487 free_array(vec2);
1488 errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
1489 }
1490
1491 result = allocate_array(result_size);
1492
1493 /* Copy the elements to keep from vec1 into result.
1494 * We count down result_size to be able to stop as early
1495 * as possible.
1496 */
1497 for ( dest = result->item, i = 0
1498 ; i < vec1_size && result_size != 0
1499 ; i++
1500 )
1501 {
1502 if (flags[i])
1503 {
1504 assign_svalue_no_free(dest, vec1->item+i);
1505 dest++;
1506 result_size--;
1507 }
1508 }
1509
1510 /* Cleanup and return */
1511 xfree(flags);
1512 free_array(vec1);
1513 free_array(vec2);
1514
1515 return result;
1516 } /* intersect_array() */
1517
1518 /*-------------------------------------------------------------------------*/
1519 vector_t *
join_array(vector_t * vec1,vector_t * vec2)1520 join_array (vector_t *vec1, vector_t *vec2)
1521
1522 /* OPERATOR | (array union)
1523 *
1524 * Perform a join of the two vectors <vec1> and <vec2>.
1525 * The result is a new vector with all elements <vec1> and those elements
1526 * from <vec2> which are not present in <vec1>.
1527 *
1528 * Both <vec1> and <vec2> are freed.
1529 */
1530
1531 {
1532 Bool *flags; /* The result from match_arrays() */
1533 size_t result_size; /* Size of the result array */
1534 vector_t *result; /* Result array */
1535 svalue_t *src; /* Pointer for getting the result elements */
1536 svalue_t *dest; /* Pointer for storing the result elements */
1537 size_t i;
1538
1539 size_t vec1_size = VEC_SIZE(vec1);
1540 size_t vec2_size = VEC_SIZE(vec2);
1541 size_t sum_size = vec1_size + vec2_size;
1542
1543 /* Handle empty arrays quickly */
1544
1545 if (vec1_size == 0)
1546 {
1547 free_array(vec1);
1548 return vec2;
1549 }
1550
1551 if (vec2_size == 0)
1552 {
1553 free_array(vec2);
1554 return vec1;
1555 }
1556
1557 /* Non-trivial arrays: match them up */
1558 flags = match_arrays(vec1, vec2);
1559
1560 /* Count how many elements have to be copied from vec2
1561 * (we have to get all from vec1 anyway) and allocate the result array.
1562 */
1563 result_size = 0;
1564 for (i = vec1_size; i < sum_size; i++)
1565 {
1566 if (!flags[i])
1567 result_size++;
1568 }
1569
1570 if (result_size == 0)
1571 {
1572 /* No elements to copy */
1573 xfree(flags);
1574 free_array(vec2);
1575 return vec1;
1576 }
1577
1578 if (max_array_size && result_size+vec1_size > max_array_size)
1579 {
1580 xfree(flags);
1581 errorf("Illegal array size: %lu.\n", (unsigned long)(result_size+vec1_size));
1582 }
1583
1584 result = allocate_array(vec1_size+result_size);
1585
1586 /* Copy the elements to keep from vec1 into result.
1587 */
1588 for (dest = result->item, i = 0 ; i < vec1_size ; i++)
1589 {
1590 assign_svalue_no_free(dest, vec1->item+i);
1591 dest++;
1592 }
1593
1594 /* Copy the elements to keep from vec1 into result.
1595 * We count down result_size to be able to stop as early
1596 * as possible.
1597 */
1598 for ( src = vec2->item, dest = result->item + vec1_size, i = vec1_size
1599 ; i < sum_size && result_size != 0
1600 ; i++, src++
1601 )
1602 {
1603 if (!flags[i])
1604 {
1605 assign_svalue_no_free(dest, src);
1606 dest++;
1607 result_size--;
1608 }
1609 }
1610
1611 /* Cleanup and return */
1612 xfree(flags);
1613 free_array(vec1);
1614 free_array(vec2);
1615
1616 return result;
1617 } /* join_array() */
1618
1619 /*-------------------------------------------------------------------------*/
1620 vector_t *
symmetric_diff_array(vector_t * vec1,vector_t * vec2)1621 symmetric_diff_array (vector_t *vec1, vector_t *vec2)
1622
1623 /* OPERATOR ^ (symmetric array difference)
1624 *
1625 * Compute the symmetric difference of the two vectors <vec1> and <vec2>.
1626 * The result is a new vector with all elements which are present in only
1627 * one of the input vectors.
1628 *
1629 * Both <vec1> and <vec2> are freed.
1630 */
1631
1632 {
1633 Bool *flags; /* The result from match_arrays() */
1634 size_t result_size; /* Size of the result array */
1635 vector_t *result; /* Result array */
1636 svalue_t *src; /* Pointer for getting the result elements */
1637 svalue_t *dest; /* Pointer for storing the result elements */
1638 size_t i;
1639
1640 size_t vec1_size = VEC_SIZE(vec1);
1641 size_t vec2_size = VEC_SIZE(vec2);
1642 size_t sum_size = vec1_size + vec2_size;
1643
1644 /* Handle empty arrays quickly */
1645
1646 if (vec1_size == 0)
1647 {
1648 free_array(vec1);
1649 return vec2;
1650 }
1651
1652 if (vec2_size == 0)
1653 {
1654 free_array(vec2);
1655 return vec1;
1656 }
1657
1658 /* Non-trivial arrays: match them up */
1659 flags = match_arrays(vec1, vec2);
1660
1661 /* Count how many elements have to be copied
1662 * and allocate the result array.
1663 */
1664 for (i = result_size = 0; i < sum_size; i++)
1665 {
1666 if (!flags[i])
1667 result_size++;
1668 }
1669
1670 if (max_array_size && result_size > max_array_size)
1671 {
1672 xfree(flags);
1673 errorf("Illegal array size: %lu.\n", (unsigned long)result_size);
1674 }
1675
1676 result = allocate_array(result_size);
1677
1678 /* Copy the elements to keep from vec1 into result.
1679 * We count down result_size to be able to stop as early
1680 * as possible.
1681 */
1682 dest = result->item;
1683 for ( src = vec1->item, i = 0
1684 ; i < vec1_size && result_size != 0
1685 ; i++, src++
1686 )
1687 {
1688 if (!flags[i])
1689 {
1690 assign_svalue_no_free(dest, src);
1691 dest++;
1692 result_size--;
1693 }
1694 }
1695
1696 /* Copy the elements to keep from vec2 into result, starting
1697 * at the current position <dest>.
1698 * We count down result_size to be able to stop as early
1699 * as possible.
1700 */
1701 for ( src = vec2->item, i = vec1_size
1702 ; i < sum_size && result_size != 0
1703 ; i++, src++
1704 )
1705 {
1706 if (!flags[i])
1707 {
1708 assign_svalue_no_free(dest, src);
1709 dest++;
1710 result_size--;
1711 }
1712 }
1713
1714 /* Cleanup and return */
1715 xfree(flags);
1716 free_array(vec1);
1717 free_array(vec2);
1718
1719 return result;
1720 } /* symmetric_diff_array() */
1721
1722 /*-------------------------------------------------------------------------*/
1723 Bool
is_ordered(vector_t * v)1724 is_ordered (vector_t *v)
1725
1726 /* Determine if <v> satisfies the conditions for being an ordered vector.
1727 * Return true if yes, false if not.
1728 *
1729 * The conditions are:
1730 * - every string is shared
1731 * - all elements are sorted according to svalue_cmp().
1732 *
1733 * This predicate is currently used just by the swapper, historically
1734 * to avoid swapping out alist values. This is because the internal order
1735 * is based on pointer values and thus unreproducible.
1736 */
1737
1738 {
1739 svalue_t *svp;
1740 mp_int i;
1741
1742 for (svp = v->item, i = (mp_int)VEC_SIZE(v); --i > 0; svp++) {
1743 if (svp->type == T_STRING && !mstr_tabled(svp->u.str))
1744 return MY_FALSE;
1745 if (svalue_cmp(svp, svp+1) > 0)
1746 return MY_FALSE;
1747 }
1748 if (svp->type == T_STRING && !mstr_tabled(svp->u.str))
1749 return MY_FALSE;
1750
1751 return MY_TRUE;
1752 } /* is_ordered() */
1753
1754 /*=========================================================================*/
1755
1756 /* EFUNS */
1757
1758 /*-------------------------------------------------------------------------*/
1759 svalue_t *
v_allocate(svalue_t * sp,int num_arg)1760 v_allocate (svalue_t *sp, int num_arg)
1761
1762 /* EFUN allocate()
1763 *
1764 * mixed *allocate(int|int* size)
1765 * mixed *allocate(int|int* size, mixed init_value)
1766 *
1767 * Allocate an array of <size> elements (if <size> is an array, the result
1768 * will be a multidimensional array), either empty or all
1769 * elements initialized with <init_value>. If <init_value> is a
1770 * mapping or array, allocate will create shallow copies of them.
1771 */
1772
1773 {
1774 vector_t *v;
1775 svalue_t *argp;
1776 size_t new_size;
1777
1778 argp = sp - num_arg + 1;
1779
1780 if (argp->type == T_NUMBER)
1781 {
1782 new_size = (size_t)argp->u.number;
1783
1784 if (num_arg == 1 || (sp->type == T_NUMBER && !sp->u.number))
1785 v = allocate_array(new_size);
1786 else
1787 {
1788 size_t i;
1789 svalue_t *svp;
1790
1791 /* If the initialisation value is a mapping, remove all
1792 * destructed elements so that we can use copy_mapping()
1793 * later on.
1794 */
1795 if (sp->type == T_MAPPING)
1796 check_map_for_destr(sp->u.map);
1797
1798 v = allocate_uninit_array(new_size);
1799 for (svp = v->item, i = 0; i < new_size; i++, svp++)
1800 copy_svalue_no_free(svp, sp);
1801 }
1802 }
1803 else if (argp->type == T_POINTER
1804 && ( VEC_SIZE(argp->u.vec) == 0
1805 || ( VEC_SIZE(argp->u.vec) == 1
1806 && argp->u.vec->item->type == T_NUMBER
1807 && argp->u.vec->item->u.number == 0)
1808 )
1809 )
1810 {
1811 /* Special case: result is the empty array.
1812 * The condition catches ( ({}) ) as well as ( ({0}) )
1813 * (the generic code below can't handle either of them).
1814 */
1815 v = allocate_array(0);
1816 }
1817 else if (argp->type == T_POINTER)
1818 {
1819 svalue_t *svp;
1820 size_t dim, num_dim;
1821 size_t count;
1822 Bool hasInitValue = MY_FALSE;
1823 size_t * curpos = alloca(VEC_SIZE(argp->u.vec) * sizeof(*curpos));
1824 size_t * sizes = alloca(VEC_SIZE(argp->u.vec) * sizeof(*sizes));
1825 vector_t ** curvec = alloca(VEC_SIZE(argp->u.vec) * sizeof(*curvec));
1826
1827 num_dim = VEC_SIZE(argp->u.vec);
1828
1829 if (!curpos || !curvec || !sizes)
1830 {
1831 errorf("Out of stack memory.\n");
1832 /* NOTREACHED */
1833 }
1834
1835 if (num_arg == 2 && (sp->type != T_NUMBER || sp->u.number != 0))
1836 {
1837 hasInitValue = MY_TRUE;
1838
1839 /* If the initialisation value is a mapping, remove all
1840 * destructed elements so that we can use copy_mapping()
1841 * later on.
1842 */
1843 if (sp->type == T_MAPPING)
1844 check_map_for_destr(sp->u.map);
1845 }
1846
1847 /* Check the size array for consistency, and also count how many
1848 * elements we're going to allocate.
1849 */
1850 for ( dim = 0, count = 0, svp = argp->u.vec->item
1851 ; dim < num_dim
1852 ; dim++, svp++
1853 )
1854 {
1855 p_int size;
1856
1857 if (svp->type != T_NUMBER)
1858 {
1859 errorf("Bad argument to allocate(): size[%d] is a '%s', "
1860 "expected 'int'.\n"
1861 , (int)dim, typename(svp->type));
1862 /* NOTREACHED */
1863 }
1864
1865 size = svp->u.number;
1866
1867 if (size < 0 || (max_array_size && (size_t)size > max_array_size))
1868 errorf("Illegal array size: %"PRIdPINT"\n", size);
1869
1870 if (size == 0 && dim < num_dim-1)
1871 errorf("Only the last dimension can have empty arrays.\n");
1872
1873 count *= (size_t)size;
1874 if (max_array_size && count > max_array_size)
1875 errorf("Illegal total array size: %lu\n", (unsigned long)count);
1876
1877 sizes[dim] = (size_t)size;
1878 curvec[dim] = NULL;
1879 }
1880
1881 /* Now loop over the dimensions, creating the array structure */
1882 dim = 0;
1883 curpos[0] = 0;
1884 while (dim > 0 || curpos[0] < sizes[0])
1885 {
1886 if (!curvec[dim])
1887 {
1888 /* We just entered this dimension.
1889 * Create a new array and initialise the loop.
1890 */
1891 if (hasInitValue || dim+1 < num_dim)
1892 {
1893 curvec[dim] = allocate_uninit_array(sizes[dim]);
1894 }
1895 else
1896 {
1897 curvec[dim] = allocate_array(sizes[dim]);
1898 /* This is the last dimension, and there is nothing
1899 * to initialize: return immediately to the higher level
1900 */
1901 curpos[dim] = sizes[dim]; /* In case dim == 0 */
1902 if (dim > 0)
1903 dim--;
1904 continue;
1905 }
1906 curpos[dim] = 0;
1907 }
1908
1909 /* curvec[dim] is valid, and we have to put the next
1910 * element in at index curpos[dim].
1911 */
1912 if (dim == num_dim-1)
1913 {
1914 /* Last dimension: assign the init value */
1915 if (hasInitValue && curpos[dim] < sizes[dim])
1916 copy_svalue_no_free(curvec[dim]->item+curpos[dim], sp);
1917 }
1918 else if (!curvec[dim+1])
1919 {
1920 /* We need a vector from a lower dimension, but it doesn't
1921 * exist yet: setup the loop parameters to go into
1922 * that lower level.
1923 */
1924 dim++;
1925 continue;
1926 }
1927 else if (curpos[dim] < sizes[dim])
1928 {
1929 /* We got a vector from a lower lever */
1930 put_array(curvec[dim]->item+curpos[dim], curvec[dim+1]);
1931 curvec[dim+1] = NULL;
1932 }
1933
1934 /* Continue to the next element. If we are at the end
1935 * of this dimension, return to the next higher one.
1936 */
1937 curpos[dim]++;
1938 if (curpos[dim] >= sizes[dim] && dim > 0)
1939 {
1940 dim--;
1941 }
1942 } /* while() */
1943
1944 /* The final vector is now in curvec[0] */
1945 v = curvec[0];
1946 }
1947 else
1948 {
1949 /* The type checker should prevent this case */
1950 fatal("Illegal arg 1 to allocate(): got '%s', expected 'int|int*'.\n"
1951 , typename(argp->type));
1952 } /* if (argp->type) */
1953
1954 if (num_arg == 2)
1955 free_svalue(sp--);
1956
1957 free_svalue(sp);
1958 put_array(sp, v);
1959
1960 return sp;
1961 } /* v_allocate() */
1962
1963 /*-------------------------------------------------------------------------*/
1964 svalue_t *
x_filter_array(svalue_t * sp,int num_arg)1965 x_filter_array (svalue_t *sp, int num_arg)
1966
1967 /* EFUN: filter() for arrays.
1968 *
1969 * mixed *filter(mixed *arr, string fun)
1970 * mixed *filter(mixed *arr, string fun, string|object obj, mixed extra, ...)
1971 * mixed *filter(mixed *arr, closure cl, mixed extra, ...)
1972 * mixed *filter(mixed *arr, mapping map)
1973 *
1974 * Filter the elements of <arr> through a filter defined by the other
1975 * arguments, and return an array of those elements, for which the
1976 * filter yields non-zero.
1977 *
1978 * The filter can be a function call:
1979 *
1980 * <obj>-><fun>(elem, <extra>...)
1981 *
1982 * or a mapping query:
1983 *
1984 * <map>[elem]
1985 *
1986 * <obj> can both be an object reference or a filename. If omitted,
1987 * this_object() is used (this also works if the third argument is
1988 * neither a string nor an object).
1989 *
1990 * As a bonus, all references to destructed objects in <arr> are replaced
1991 * by proper 0es.
1992 *
1993 * TODO: Autodoc-Feature to create doc/efun/filter_array automatically.
1994 */
1995
1996 {
1997 svalue_t *arg; /* First argument the vm stack */
1998 vector_t *p; /* The filtered vector */
1999 mp_int p_size; /* sizeof(*p) */
2000 vector_t *vec;
2001 svalue_t *v, *w;
2002 char *flags; /* Flag array, one flag for each element of <p>
2003 * (in reverse order) */
2004 int res; /* Number of surviving elements */
2005 int cnt;
2006
2007 res = 0;
2008
2009 /* Locate the args on the stack, extract the vector to filter
2010 * and allocate the flags vector.
2011 */
2012 arg = sp - num_arg + 1;
2013
2014 p = arg->u.vec;
2015 p_size = (mp_int)VEC_SIZE(p);
2016
2017 flags = alloca((size_t)p_size+1);
2018 if (!flags)
2019 {
2020 errorf("Stack overflow in filter()");
2021 /* NOTREACHED */
2022 return sp;
2023 }
2024
2025 /* Every element in flags is associated by index number with an
2026 * element in the vector to filter. The filter function is evaluated
2027 * for every vector element, and the associated flag is set to 0
2028 * or 1 according to the result.
2029 * At the end, all 1-flagged elements are gathered and copied
2030 * into the result vector.
2031 */
2032
2033 if (arg[1].type == T_MAPPING) {
2034
2035 /* --- Filter by mapping query --- */
2036 mapping_t *m;
2037
2038 if (num_arg > 2) {
2039 inter_sp = sp;
2040 errorf("Too many arguments to filter(array)\n");
2041 }
2042 m = arg[1].u.map;
2043
2044 for (w = p->item, cnt = p_size; --cnt >= 0; )
2045 {
2046 if (destructed_object_ref(w))
2047 assign_svalue(w, &const0);
2048 if (get_map_value(m, w++) == &const0) {
2049 flags[cnt] = 0;
2050 continue;
2051 }
2052 flags[cnt] = 1;
2053 res++;
2054 }
2055
2056 free_svalue(arg+1);
2057 sp = arg;
2058
2059 } else {
2060
2061 /* --- Filter by function call --- */
2062
2063 int error_index;
2064 callback_t cb;
2065
2066 assign_eval_cost();
2067 inter_sp = sp;
2068
2069 error_index = setup_efun_callback(&cb, arg+1, num_arg-1);
2070
2071 if (error_index >= 0)
2072 {
2073 vefun_bad_arg(error_index+2, arg);
2074 /* NOTREACHED */
2075 return arg;
2076 }
2077 inter_sp = sp = arg+1;
2078 put_callback(sp, &cb);
2079
2080 /* Loop over all elements in p and call the filter.
2081 * w is the current element filtered.
2082 */
2083 for (w = p->item, cnt = p_size; --cnt >= 0; )
2084 {
2085 flags[cnt] = 0;
2086
2087 if (current_object->flags & O_DESTRUCTED)
2088 continue;
2089 /* Don't call the filter anymore, but fill the
2090 * flags array with 0es.
2091 */
2092
2093 if (destructed_object_ref(w))
2094 assign_svalue(w, &const0);
2095
2096 if (!callback_object(&cb))
2097 {
2098 inter_sp = sp;
2099 errorf("object used by filter(array) destructed");
2100 }
2101
2102 push_svalue(w++);
2103
2104 v = apply_callback(&cb, 1);
2105 if (!v || (v->type == T_NUMBER && !v->u.number) )
2106 continue;
2107
2108 flags[cnt] = 1;
2109 res++;
2110 }
2111
2112 free_callback(&cb);
2113 }
2114
2115 /* flags[] holds the filter results, res is the number of
2116 * elements to keep. Now create the result vector.
2117 */
2118 vec = allocate_array(res);
2119 if (res) {
2120 for(v = p->item, w = vec->item, flags = &flags[p_size]; ; v++) {
2121 if (*--flags) {
2122 assign_svalue_no_free (w++, v);
2123 if (--res <= 0) break;
2124 }
2125 }
2126 }
2127
2128 /* Cleanup (everything but the array has been removed already) */
2129 free_array(p);
2130 arg->u.vec = vec;
2131
2132 return arg;
2133 } /* x_filter_array() */
2134
2135 /*-------------------------------------------------------------------------*/
2136 svalue_t *
x_map_array(svalue_t * sp,int num_arg)2137 x_map_array (svalue_t *sp, int num_arg)
2138
2139 /* EFUN map() on arrays
2140 *
2141 * mixed * map(mixed * arg, string func, string|object ob, mixed extra...)
2142 * mixed * map(mixed * arg, closure cl, mixed extra...)
2143 * mixed * map(mixed * arr, mapping map [, int col])
2144 *
2145 * Map the elements of <arr> through a filter defined by the other
2146 * arguments, and return an array of the elements returned by the filter.
2147 *
2148 * The filter can be a function call:
2149 *
2150 * <obj>-><fun>(elem, <extra>...)
2151 *
2152 * or a mapping query:
2153 *
2154 * <map>[elem[,idx]]
2155 *
2156 * In the mapping case, if <map>[elem[,idx]] does not exist, the original
2157 * value is returned in the result.
2158 * [Note: argument type and range checking for idx is done in v_map()]
2159 *
2160 * <obj> can both be an object reference or a filename. If <ob> is
2161 * omitted, or neither an object nor a string, then this_object() is used.
2162 *
2163 * As a bonus, all references to destructed objects in <arr> are replaced
2164 * by proper 0es.
2165 */
2166
2167 {
2168 vector_t *arr;
2169 vector_t *res;
2170 svalue_t *arg;
2171 svalue_t *v, *w, *x;
2172 mp_int cnt;
2173
2174 inter_sp = sp;
2175
2176 arg = sp - num_arg + 1;
2177
2178 arr = arg->u.vec;
2179 cnt = (mp_int)VEC_SIZE(arr);
2180
2181 if (arg[1].type == T_MAPPING)
2182 {
2183 /* --- Map through mapping --- */
2184
2185 mapping_t *m;
2186 p_int column = 0; /* mapping column to use */
2187
2188 m = arg[1].u.map;
2189
2190 if (num_arg > 2)
2191 column = arg[2].u.number;
2192
2193 res = allocate_array(cnt);
2194 if (!res)
2195 errorf("(map_array) Out of memory: array[%"PRIdMPINT
2196 "] for result\n", cnt);
2197 push_array(inter_sp, res); /* In case of errors */
2198
2199 for (w = arr->item, x = res->item; --cnt >= 0; w++, x++)
2200 {
2201 if (destructed_object_ref(w))
2202 assign_svalue(w, &const0);
2203
2204 v = get_map_value(m, w);
2205 if (v == &const0)
2206 assign_svalue_no_free(x, w);
2207 else
2208 assign_svalue_no_free(x, v + column);
2209 }
2210
2211 if (num_arg > 2)
2212 free_svalue(arg+2);
2213 free_svalue(arg+1); /* the mapping */
2214 sp = arg;
2215 }
2216 else
2217 {
2218 /* --- Map through function call --- */
2219
2220 callback_t cb;
2221 int error_index;
2222
2223 error_index = setup_efun_callback(&cb, arg+1, num_arg-1);
2224 if (error_index >= 0)
2225 {
2226 vefun_bad_arg(error_index+2, arg);
2227 /* NOTREACHED */
2228 return arg;
2229 }
2230 inter_sp = sp = arg+1;
2231 put_callback(sp, &cb);
2232 num_arg = 2;
2233
2234 res = allocate_array(cnt);
2235 if (!res)
2236 errorf("(map_array) Out of memory: array[%"PRIdMPINT
2237 "] for result\n", cnt);
2238 push_array(inter_sp, res); /* In case of errors */
2239
2240 /* Loop through arr and res, mapping the values from arr */
2241 for (w = arr->item, x = res->item; --cnt >= 0; w++, x++)
2242 {
2243 if (current_object->flags & O_DESTRUCTED)
2244 continue;
2245
2246 if (destructed_object_ref(w))
2247 assign_svalue(w, &const0);
2248
2249 if (!callback_object(&cb))
2250 errorf("object used by map(array) destructed");
2251
2252 push_svalue(w);
2253
2254 v = apply_callback(&cb, 1);
2255 if (v)
2256 {
2257 transfer_svalue_no_free(x, v);
2258 v->type = T_INVALID;
2259 }
2260 }
2261
2262 free_callback(&cb);
2263 }
2264
2265 /* The arguments have been removed already, now just replace
2266 * the arr on the stack with the result.
2267 */
2268 free_array(arr);
2269 arg->u.vec = res; /* Keep svalue type: T_POINTER */
2270
2271 return arg;
2272 } /* x_map_array () */
2273
2274 /*-------------------------------------------------------------------------*/
2275 svalue_t *
v_sort_array(svalue_t * sp,int num_arg)2276 v_sort_array (svalue_t * sp, int num_arg)
2277
2278 /* EFUN sort_array()
2279 *
2280 * mixed *sort_array(mixed *arr, string wrong_order
2281 * , object|string ob, mixed extra...)
2282 * mixed *sort_array(mixed *arr, closure cl, mixed extra...)
2283 *
2284 * Create a shallow copy of array <arr> and sort that copy by the ordering
2285 * function ob->wrong_order(a, b), or by the closure expression 'cl'.
2286 * The sorted copy is returned as result.
2287 *
2288 * If the 'arr' argument equals 0, the result is also 0.
2289 * 'ob' is the object in which the ordering function is called
2290 * and may be given as object or by its filename.
2291 * If <ob> is omitted, or neither an object nor a string, then
2292 * this_object() is used.
2293 *
2294 * The elements from the array to be sorted are passed in pairs to
2295 * the function 'wrong_order' as arguments, followed by any <extra>
2296 * arguments.
2297 *
2298 * The function should return a positive number if the elements
2299 * are in the wrong order. It should return 0 or a negative
2300 * number if the elements are in the correct order.
2301 *
2302 * The sorting is implemented using Mergesort, which gives us a O(N*logN)
2303 * worst case behaviour and provides a stable sort.
2304 */
2305
2306 {
2307 vector_t *data;
2308 svalue_t *arg;
2309 callback_t cb;
2310 int error_index;
2311 mp_int step, halfstep, size;
2312 int i, j, index1, index2, end1, end2;
2313 svalue_t *source, *dest, *temp;
2314 Bool inplace = MY_FALSE;
2315
2316 arg = sp - num_arg + 1;
2317
2318 error_index = setup_efun_callback(&cb, arg+1, num_arg-1);
2319 if (error_index >= 0)
2320 {
2321 vefun_bad_arg(error_index+2, arg);
2322 /* NOTREACHED */
2323 return arg;
2324 }
2325 inter_sp = sp = arg+1;
2326 put_callback(sp, &cb);
2327 num_arg = 2;
2328
2329 /* If the argument is passed in by reference, make sure that it is
2330 * an array, place the argument vector directly into the stack and set
2331 * inplace.
2332 */
2333 if (arg->type == T_LVALUE)
2334 {
2335 svalue_t * svp = arg;
2336 vector_t * vec = NULL;
2337
2338 do {
2339 svp = svp->u.lvalue;
2340 } while (svp->type == T_LVALUE || svp->type == T_PROTECTED_LVALUE);
2341
2342 if (svp->type != T_POINTER)
2343 {
2344 inter_sp = sp;
2345 errorf("Bad arg 1 to sort_array(): got '%s &', "
2346 "expected 'mixed * / mixed *&'.\n"
2347 , typename(svp->type));
2348 // NOTREACHED
2349 return sp;
2350 }
2351
2352 inplace = MY_TRUE;
2353
2354 vec = ref_array(svp->u.vec);
2355 free_svalue(arg);
2356 put_array(arg, vec);
2357 }
2358
2359
2360 /* Get the array. Since the sort sorts in-place, we have
2361 * to make a shallow copy of arrays with more than one
2362 * ref. Exception is, if the array is given as reference/lvalue, then we
2363 * always sort in-place.
2364 */
2365 data = arg->u.vec;
2366 check_for_destr(data);
2367
2368 if (!inplace && data->ref != 1)
2369 {
2370 vector_t *vcopy;
2371
2372 vcopy = slice_array(data, 0, VEC_SIZE(data)-1);
2373 free_array(data);
2374 data = vcopy;
2375 arg->u.vec = data;
2376 }
2377
2378 size = (mp_int)VEC_SIZE(data);
2379
2380 /* Easiest case: nothing to sort */
2381 if (size <= 1)
2382 {
2383 free_callback(&cb);
2384 return arg;
2385 }
2386
2387 /* In order to provide clean error recovery, data must always hold
2388 * exactly one copy of each original content svalue when an error is
2389 * possible. Thus, it would be not a good idea to use it as scrap
2390 * space.
2391 */
2392
2393 temp = data->item;
2394
2395 source = alloca(size*sizeof(svalue_t));
2396 dest = alloca(size*sizeof(svalue_t));
2397 if (!source || !dest)
2398 {
2399 errorf("Stack overflow in sort_array()");
2400 /* NOTREACHED */
2401 return arg;
2402 }
2403
2404 for (i = 0; i < size; i++)
2405 source[i] = temp[i];
2406
2407 step = 2;
2408 halfstep = 1;
2409 while (halfstep<size)
2410 {
2411 for (i = j = 0; i < size; i += step)
2412 {
2413 index1 = i;
2414 index2 = i + halfstep;
2415 end1 = index2;
2416 if (end1 > size)
2417 end1 = size;
2418 end2 = i + step;
2419 if (end2 > size)
2420 end2 = size;
2421
2422 while (index1 < end1 && index2 < end2)
2423 {
2424 svalue_t *d;
2425
2426 if (!callback_object(&cb))
2427 errorf("object used by sort_array destructed");
2428
2429 push_svalue(source+index1);
2430 push_svalue(source+index2);
2431 d = apply_callback(&cb, 2);
2432
2433 if (d && (d->type != T_NUMBER || d->u.number > 0))
2434 dest[j++] = source[index2++];
2435 else
2436 dest[j++] = source[index1++];
2437 }
2438
2439 if (index1 == end1)
2440 {
2441 while (index2 < end2)
2442 dest[j++] = source[index2++];
2443 }
2444 else
2445 {
2446 while (index1 < end1)
2447 dest[j++] = source[index1++];
2448 }
2449 }
2450 halfstep = step;
2451 step += step;
2452 temp = source;
2453 source = dest;
2454 dest = temp;
2455 }
2456
2457 temp = data->item;
2458 for (i = size; --i >= 0; )
2459 temp[i] = source[i];
2460
2461 free_callback(&cb);
2462 return arg;
2463 } /* v_sort_array() */
2464
2465 /*-------------------------------------------------------------------------*/
2466 svalue_t *
v_filter_objects(svalue_t * sp,int num_arg)2467 v_filter_objects (svalue_t *sp, int num_arg)
2468
2469 /* EFUN filter_objects()
2470 *
2471 * object *filter_objects (object *arr, string fun, mixed extra, ...)
2472 *
2473 * Filter the objects in <arr> by calling the lfun obj-><fun>(<extra>...)
2474 * and return an array of those objects for which the lfun call yields
2475 * non-zero.
2476 *
2477 * The objects can be true objects or filenames. In the latter case, the
2478 * function tries to load the object before calling the lfun. Any non-object
2479 * element in <arr> is ignored and thus not included in the result.
2480 *
2481 * As a bonus, all references to destructed objects in <arr> are replaced
2482 * by proper 0es.
2483 */
2484
2485 {
2486 vector_t *p; /* The <arr> argument */
2487 string_t *func; /* The <fun> argument */
2488 svalue_t *arguments; /* Beginning of 'extra' arguments on vm stack */
2489 vector_t *w; /* Result vector */
2490 CBool *flags = NULL; /* Flag array, one flag for each element of <p> */
2491 int res; /* Count of objects to return */
2492 object_t *ob; /* Object to call */
2493 mp_int p_size; /* Size of <p> */
2494 int cnt = 0;
2495 svalue_t *v;
2496
2497 assign_eval_cost();
2498 inter_sp = sp; /* needed for errors in allocate_array(), apply() */
2499
2500 /* Locate the arguments on the stack and extract them */
2501 arguments = sp-num_arg+3;
2502
2503 p = arguments[-2].u.vec;
2504 func = arguments[-1].u.str;
2505 num_arg -= 2;
2506
2507 p_size = (mp_int)VEC_SIZE(p);
2508
2509 /* Call <func> in every object, recording the result in flags.
2510 *
2511 * Every element in flags is associated by index number with an
2512 * element in the vector to filter. The filter function is evaluated
2513 * for every vector element, and the associated flag is set to 0
2514 * or 1 according to the result.
2515 * At the end, all 1-flagged elements are gathered and copied
2516 * into the result vector.
2517 *
2518 * Checking if <func> exists as shared string takes advantage of
2519 * the fact that every existing lfun name is stored as shared string.
2520 * If it's not shared, no object implements it and we can skip
2521 * the whole function call loop.
2522 */
2523
2524 res = 0;
2525
2526 func = find_tabled(func);
2527 if (NULL != func)
2528 {
2529 flags = alloca((p_size+1)*sizeof(*flags));
2530 if (!flags)
2531 {
2532 errorf("Stack overflow in filter_objects()");
2533 /* NOTREACHED */
2534 return NULL;
2535 }
2536
2537 for (cnt = 0; cnt < p_size; cnt++) {
2538 flags[cnt] = MY_FALSE;
2539 v = &p->item[cnt];
2540
2541 /* Coerce <v> into a (non-destructed) object ob (if necessary
2542 * by loading it). If that doesn't work, simply continue
2543 * with the next element.
2544 */
2545 if (v->type != T_OBJECT)
2546 {
2547 if (v->type != T_STRING)
2548 continue;
2549 if ( !(ob = get_object(v->u.str)) )
2550 continue;
2551 } else {
2552 ob = v->u.ob;
2553 if (ob->flags & O_DESTRUCTED)
2554 {
2555 assign_svalue(v, &const0);
2556 continue;
2557 }
2558 }
2559
2560 /* Abort the efun if this_object is destructed (slightly
2561 * strange place to check for it).
2562 */
2563 if (current_object->flags & O_DESTRUCTED)
2564 continue;
2565
2566 /* Call the filter lfun and record the result. */
2567 push_svalue_block(num_arg, arguments);
2568 v = sapply (func, ob, num_arg);
2569 if ((v) && (v->type!=T_NUMBER || v->u.number) ) {
2570 flags[cnt] = MY_TRUE;
2571 res++;
2572 }
2573 } /* for() */
2574 } /* if() */
2575
2576 /* Now: cnt == p_size, res == number of 'true' flags */
2577
2578 /* Create the result vector and fill it with all objects for which
2579 * true flag was recorded.
2580 */
2581
2582 w = allocate_array(res); /* might be a 0-elements array */
2583
2584 if (res) {
2585
2586 /* Walk through flags/w->item from the end, copying all
2587 * positively flagged elements from p.
2588 */
2589
2590 v = &w->item[res];
2591 for (;;) {
2592 if (flags[--cnt])
2593 {
2594 svalue_t sv;
2595
2596 /* Copy the element and update the ref-count */
2597
2598 *--v = sv = p->item[cnt];
2599 if (sv.type == T_STRING)
2600 {
2601 (void)ref_mstring(sv.u.str);
2602 }
2603 else
2604 {
2605 (void)ref_object(sv.u.ob, "filter");
2606 }
2607
2608 /* Loop termination check moved in here to save cycles */
2609 if (v == w->item)
2610 break;
2611 }
2612 } /* for () */
2613 } /* if (res) */
2614
2615 /* Cleanup and return */
2616 free_array(p);
2617
2618 do {
2619 free_svalue(sp--);
2620 } while(--num_arg >= 0);
2621
2622 put_array(sp, w);
2623 return sp;
2624 } /* v_filter_objects() */
2625
2626 /*-------------------------------------------------------------------------*/
2627 svalue_t *
v_map_objects(svalue_t * sp,int num_arg)2628 v_map_objects (svalue_t *sp, int num_arg)
2629
2630 /* EFUN map_objects()
2631 *
2632 * mixed *map_objects (object *arr, string fun, mixed extra, ...)
2633 *
2634 * Map the objects in <arr> by calling the lfun obj-><fun>(<extra>...)
2635 * and return an array of the function call results.
2636 *
2637 * The objects can be true objects or filenames. In the latter case, the
2638 * function tries to load the object before calling the lfun. Any non-object
2639 * element in <arr> is ignored and a 0 is returned in its place.
2640 *
2641 * As a bonus, all references to destructed objects in <arr> are replaced
2642 * by proper 0es.
2643 */
2644
2645 {
2646 vector_t *p; /* The <arr> argument */
2647 string_t *func; /* The <fun> argument */
2648 svalue_t *arguments; /* Beginning of 'extra' arguments on vm stack */
2649 vector_t *r; /* Result vector */
2650 object_t *ob; /* Object to call */
2651 mp_int size; /* Size of <p> */
2652 int cnt;
2653 svalue_t *w, *v, *x;
2654
2655 assign_eval_cost();
2656 inter_sp = sp; /* In case of errors leave a clean stack behind */
2657
2658 arguments = sp-num_arg+3;
2659
2660 p = arguments[-2].u.vec;
2661 func = arguments[-1].u.str;
2662 num_arg -= 2;
2663
2664 r = allocate_array(size = (mp_int)VEC_SIZE(p));
2665 arguments[-2].u.vec = r;
2666
2667 push_array(inter_sp, p); /* Ref it from the stack in case of errors */
2668
2669 /* Call <func> in every object, storing the result in r.
2670 *
2671 * Checking if <func> exists as shared string takes advantage of
2672 * the fact that every existing lfun name is stored as shared string.
2673 * If it's not shared, no object implements it and we can skip
2674 * the whole function call loop.
2675 */
2676
2677 func = find_tabled(func);
2678 if (NULL != func)
2679 {
2680 for (cnt = size, v = p->item, x = r->item; --cnt >= 0; v++, x++) {
2681
2682 /* Coerce <v> into a (non-destructed) object ob (if necessary
2683 * by loading it). If that doesn't work, simply continue
2684 * with the next element.
2685 */
2686 if (v->type != T_OBJECT) {
2687 if (v->type != T_STRING)
2688 continue;
2689 if ( !(ob = get_object(v->u.str)) )
2690 continue;
2691 } else {
2692 ob = v->u.ob;
2693 if (ob->flags & O_DESTRUCTED) {
2694 assign_svalue(v, &const0);
2695 continue;
2696 }
2697 }
2698
2699 /* Abort the efun if this_object is destructed (slightly
2700 * strange place to check for it).
2701 */
2702 if (current_object->flags & O_DESTRUCTED)
2703 continue;
2704
2705 /* Call the lfun and record the result */
2706 push_svalue_block(num_arg, arguments);
2707 w = sapply (func, ob, num_arg);
2708 if (w)
2709 {
2710 *x = *w;
2711 w->type = T_INVALID;
2712 }
2713 } /* for() */
2714 } /* if() */
2715
2716 /* Clean up and return */
2717 do {
2718 free_svalue(sp--);
2719 } while(--num_arg >= 0);
2720 free_array(p);
2721
2722 return sp;
2723 } /* v_map_objects() */
2724
2725 /*-------------------------------------------------------------------------*/
2726 svalue_t *
f_transpose_array(svalue_t * sp)2727 f_transpose_array (svalue_t *sp)
2728
2729 /* EFUN transpose_array()
2730 *
2731 * mixed *transpose_array (mixed *arr);
2732 *
2733 * transpose_array ( ({ ({1,2,3}), ({a,b,c}) }) )
2734 * => ({ ({1,a}), ({2,b)}, ({3,c}) })
2735 *
2736 * transpose_array() applied to an alist results in an array of
2737 * ({ key, data }) pairs, useful if you want to use sort_array()
2738 * or filter_array() on the alist.
2739 *
2740 * TODO: There should be something like this for mappings.
2741 */
2742
2743 {
2744 vector_t *v; /* Input vector */
2745 vector_t *w; /* Result vector */
2746 mp_int a; /* size of <v> */
2747 mp_int b; /* size of <v>[ix] for all ix */
2748 mp_int i, j;
2749 int no_copy;
2750 /* 1 if <v> has only one ref, else 0. Not just a boolean, it
2751 * is compared with the ref counts of the subvectors of v.
2752 */
2753 svalue_t *x, *y, *z;
2754 int o;
2755
2756 /* Get and test the arguments */
2757 v = sp->u.vec;
2758
2759 if ( !(a = (mp_int)VEC_SIZE(v)) )
2760 return sp;
2761
2762 /* Find the widest subarray in the main array */
2763 b = 0;
2764 for (x = v->item, i = a; i > 0; i--, x++)
2765 {
2766 mp_int c;
2767
2768 if (x->type != T_POINTER)
2769 {
2770 errorf("Bad arg 1 to transpose_array(): not an array of arrays.\n");
2771 /* NOTREACHED */
2772 return sp;
2773 }
2774 c = (mp_int)VEC_SIZE(x->u.vec);
2775 if (c > b)
2776 b = c;
2777 }
2778
2779 /* If all subarrays are empty, just return an empty array */
2780 if (!b)
2781 {
2782 sp->u.vec = ref_array(v->item->u.vec);
2783 free_array(v);
2784 return sp;
2785 }
2786
2787 no_copy = (v->ref == 1) ? 1 : 0;
2788
2789 /* Allocate and initialize the result vector */
2790 w = allocate_uninit_array(b);
2791 for (j = b, x = w->item; --j >= 0; x++)
2792 {
2793 put_array(x, allocate_array(a));
2794 }
2795
2796 o = offsetof(vector_t, item);
2797
2798 for (i = a, y = v->item; --i >= 0; o += sizeof(svalue_t), y++)
2799 {
2800 mp_int c;
2801
2802 x = w->item;
2803 if (y->type != T_POINTER)
2804 break;
2805
2806 z = y->u.vec->item;
2807
2808 c = b;
2809 if (VEC_SIZE(y->u.vec) < b
2810 && !(c = (mp_int)VEC_SIZE(y->u.vec)) )
2811 continue;
2812
2813 if (y->u.vec->ref == no_copy)
2814 {
2815 /* Move the values to the result vector */
2816
2817 j = c;
2818 do {
2819 transfer_svalue_no_free(
2820 (svalue_t *)((char*)x->u.vec+o),
2821 z
2822 );
2823 x++;
2824 z++;
2825 } while (--j > 0);
2826 free_empty_vector(y->u.vec);
2827 y->type = T_INVALID;
2828 }
2829 else
2830 {
2831 /* Assign the values to the result vector */
2832
2833 j = c;
2834 do {
2835 assign_svalue_no_free(
2836 (svalue_t *)((char*)x->u.vec+o),
2837 z
2838 );
2839 x++;
2840 z++;
2841 } while (--j > 0);
2842 }
2843 }
2844
2845 /* Clean up and return the result */
2846
2847 free_array(sp->u.vec);
2848 sp->u.vec = w;
2849 return sp;
2850 } /* f_transpose_array() */
2851
2852 /*=========================================================================*/
2853
2854 /* EFUN unique_array()
2855 *
2856 * mixed *unique_array (object *obarr, string seperator, mixed skip = 0)
2857 *
2858 * Group all those objects from <obarr> together for which the
2859 * <separator> function (which is called in every object) returns the
2860 * same value. Objects for which the function returns the <skip> value
2861 * and all non-object elements are omitted fully from the result.
2862 *
2863 * The returned array is an array of arrays of objects in the form:
2864 *
2865 * ({ ({ Same1:1, Same1:2, ... Same1:N }),
2866 * ({ Same2:1, Same2:2, ... Same2:N }),
2867 * ....
2868 * ({ SameM:1, SameM:2, ... SameM:N })
2869 * })
2870 *
2871 * The result of <separator>() (the 'marker value') must be a number,
2872 * a string, an object or an array.
2873 *
2874 * Basic purpose of this efun is to speed up the preparation of an
2875 * inventory description - e.g. it allows to to fold all objects with
2876 * identical descriptions into one textline.
2877 *
2878 * Other applications are possible, for example:
2879 *
2880 * mixed *arr;
2881 * arr=unique_array(users(), "_query_level", -1);
2882 *
2883 * This will return an array of arrays holding all user objects
2884 * grouped together by their user levels. Wizards have a user
2885 * level of -1 so they will not appear in the the returned array.
2886 *
2887 * TODO: Expand unique_array(), e.g. by taking a closure as function
2888 * TODO:: or provide a simulation.
2889 * TODO: Allow unique_array() to tag the returned groups with the
2890 * TODO:: value returned by the separator().
2891 * TODO: unique_array() is almost big enough for a file on its own.
2892 */
2893
2894 /*-------------------------------------------------------------------------*/
2895
2896 /* The function builds a comb of unique structures: every tooth lists
2897 * all objects with the same marker value, with the first structure
2898 * of every tooth linked together to form the spine:
2899 *
2900 * -> Marker1:1 -> Marker1:2 -> ...
2901 * |
2902 * V
2903 * Marker2:1 -> Marker2:2 -> ...
2904 * |
2905 * V
2906 * ...
2907 */
2908
2909 struct unique
2910 {
2911 int count; /* Number of structures in this tooth */
2912 svalue_t *val; /* The object itself */
2913 svalue_t mark; /* The marker value for this object */
2914 struct unique *same; /* Next structure in this tooth */
2915 struct unique *next; /* Next tooth head */
2916 };
2917
2918 /*-------------------------------------------------------------------------*/
2919 static int
sameval(svalue_t * arg1,svalue_t * arg2)2920 sameval (svalue_t *arg1, svalue_t *arg2)
2921
2922 /* Return true if <arg1> is identical to <arg2>.
2923 * For arrays, this function only compares if <arg1> and <arg2> refer
2924 * to the same array, not the values.
2925 */
2926
2927 {
2928 if (!arg1 || !arg2) return 0;
2929 if (arg1->type == T_NUMBER && arg2->type == T_NUMBER) {
2930 return arg1->u.number == arg2->u.number;
2931 } else if (arg1->type == T_POINTER && arg2->type == T_POINTER) {
2932 return arg1->u.vec == arg2->u.vec;
2933 } else if (arg1->type == T_STRING && arg2->type == T_STRING) {
2934 return mstreq(arg1->u.str, arg2->u.str);
2935 } else if (arg1->type == T_OBJECT && arg2->type == T_OBJECT) {
2936 return arg1->u.ob == arg2->u.ob;
2937 } else
2938 return 0;
2939 } /* sameval() */
2940
2941
2942 /*-------------------------------------------------------------------------*/
2943 static int
put_in(Mempool pool,struct unique ** ulist,svalue_t * marker,svalue_t * elem)2944 put_in (Mempool pool, struct unique **ulist
2945 , svalue_t *marker, svalue_t *elem)
2946
2947 /* Insert the object <elem> according to its <marker> value into the comb
2948 * of unique structures. <ulist> points to the root pointer of this comb.
2949 * Return the (new) number of distinct markers.
2950 */
2951
2952 {
2953 struct unique *llink, *slink, *tlink;
2954 int cnt; /* Number of distinct markers */
2955 Bool fixed; /* True: <elem> was inserted */
2956
2957 llink = *ulist;
2958 cnt = 0;
2959 fixed = 0;
2960
2961 /* Loop through the comb's top level, counting the distinct marker
2962 * and searching for the right teeth to insert <elem> into.
2963 */
2964 while (llink) {
2965 if (!fixed && sameval(marker, &(llink->mark))) {
2966
2967 /* Insert the new <elem> here
2968 */
2969 for (tlink = llink; tlink->same; tlink = tlink->same) tlink->count++;
2970 tlink->count++;
2971 /* TODO: Is the above really necessary?
2972 * slink = new unique; llink->same = slink; llink->count++;
2973 * should be sufficient.
2974 */
2975
2976 slink = mempool_alloc(pool, sizeof(struct unique));
2977 if (!slink)
2978 {
2979 errorf("(unique_array) Out of memory (%lu bytes pooled) "
2980 "for comb.\n", (unsigned long)sizeof(struct unique));
2981 /* NOTREACHED */
2982 return 0;
2983 }
2984 slink->count = 1;
2985 assign_svalue_no_free(&slink->mark,marker);
2986 slink->val = elem;
2987 slink->same = NULL;
2988 slink->next = NULL;
2989 tlink->same = slink;
2990
2991 fixed = 1; /* ...just continue to count now */
2992 /* TODO: Do not recount the comb size all the time! */
2993 }
2994
2995 llink=llink->next;
2996 cnt++;
2997 }
2998 if (fixed)
2999 return cnt;
3000
3001 /* It's a really new marker -> start a new tooth in the comb.
3002 */
3003 llink = mempool_alloc(pool, sizeof(struct unique));
3004 if (!llink)
3005 {
3006 errorf("(unique_array) Out of memory (%lu bytes pooled) "
3007 "for comb.\n", (unsigned long)sizeof(struct unique));
3008 /* NOTREACHED */
3009 return 0;
3010 }
3011 llink->count = 1;
3012 assign_svalue_no_free(&llink->mark,marker);
3013 llink->val = elem;
3014 llink->same = NULL;
3015
3016 llink->next = *ulist;
3017 *ulist = llink;
3018
3019 return cnt+1;
3020 } /* put_in() */
3021
3022
3023 /*-------------------------------------------------------------------------*/
3024 /* To facilitate automatic cleanup of the temporary structures in case
3025 * of an error, the following structure will be pushed onto the VM stack
3026 * as T_ERROR_HANDLER.
3027 */
3028
3029 struct unique_cleanup_s {
3030 svalue_t head; /* The link to the error handler function */
3031 Mempool pool; /* Pool for the unique structures */
3032 vector_t * arr; /* Protective reference to the array */
3033 };
3034
3035 static void
make_unique_cleanup(svalue_t * arg)3036 make_unique_cleanup (svalue_t * arg)
3037 {
3038 struct unique_cleanup_s * data = (struct unique_cleanup_s *)arg;
3039
3040 if (data->pool)
3041 mempool_delete(data->pool);
3042 if (data->arr)
3043 deref_array(data->arr);
3044 xfree(arg);
3045 } /* make_unique_cleanup() */
3046
3047 /*-------------------------------------------------------------------------*/
3048 static vector_t *
make_unique(vector_t * arr,callback_t * cb,svalue_t * skipnum)3049 make_unique (vector_t *arr, callback_t *cb, svalue_t *skipnum)
3050
3051 /* The actual implementation of efun unique_array();
3052 *
3053 * The caller made sure that <arr> contains no destructed objects.
3054 */
3055
3056 {
3057 Mempool pool; /* Pool for the unique structures */
3058 svalue_t *v;
3059 vector_t *ret; /* Result vector */
3060 vector_t *res; /* Current sub vector in ret */
3061 struct unique *head; /* Head of the unique comb */
3062 struct unique *nxt;
3063 mp_int arr_size; /* Size of the incoming <arr>ay */
3064 mp_int ant; /* Number of distinct markers */
3065 mp_int cnt, cnt2;
3066 struct unique_cleanup_s * ucp;
3067
3068 head = NULL;
3069
3070 arr_size = (mp_int)VEC_SIZE(arr);
3071
3072 /* Special case: unifying an empty array */
3073 if (!arr_size)
3074 return allocate_array(0);
3075
3076 /* Get the memory for the arr_size unique-structures we're going
3077 * to need.
3078 */
3079 pool = new_mempool(size_mempool(sizeof(*head)));
3080 if (!pool)
3081 errorf("(unique_array) Out of memory: (%lu bytes) for mempool\n"
3082 , (unsigned long)arr_size * sizeof(*head));
3083
3084 /* Create the automatic cleanup structure */
3085 ucp = xalloc(sizeof(*ucp));
3086 if (!ucp)
3087 {
3088 mempool_delete(pool);
3089 errorf("(unique_array) Out of memory: (%lu bytes) for cleanup structure\n"
3090 , (unsigned long)sizeof(*ucp));
3091 }
3092
3093 ucp->pool = pool;
3094 ucp->arr = ref_array(arr); /* Prevent apply from freeing this */
3095
3096 push_error_handler(make_unique_cleanup, &(ucp->head));
3097
3098 /* Build the comb structure.
3099 */
3100 ant = 0;
3101 for (cnt = 0; cnt < arr_size; cnt++)
3102 {
3103 if (current_object->flags & O_DESTRUCTED)
3104 break;
3105 /* Don't call the filters anymore */
3106
3107 if (arr->item[cnt].type == T_OBJECT
3108 && !destructed_object_ref(&(arr->item[cnt]))
3109 )
3110 {
3111 /* It's usually done the other way around, but not here: if
3112 * it's a closure, we pass the object analyzed; otherwise we
3113 * change the object the callback is bound to to call the
3114 * discriminator function in it.
3115 */
3116 if (!cb->is_lambda)
3117 callback_change_object(cb, arr->item[cnt].u.ob);
3118 else
3119 push_ref_object(inter_sp, arr->item[cnt].u.ob, "unique_array");
3120
3121 v = apply_callback(cb, cb->is_lambda ? 1 : 0);
3122 if (v && !sameval(v, skipnum))
3123 ant = put_in(pool, &head, v, &(arr->item[cnt]));
3124 }
3125 }
3126
3127 ret = allocate_array(ant);
3128
3129 /* Copy the objects from the comb structure into the result vector,
3130 * deallocating the structure by this.
3131 * The elements are stored in reverse to compensate put_in(),
3132 * but TODO: does someone really care?
3133 */
3134
3135 for (cnt = ant-1; cnt >= 0; cnt--) {
3136 res = allocate_array(head->count);
3137 put_array(ret->item+cnt, res);
3138
3139 nxt = head;
3140 head = head->next;
3141
3142 cnt2 = 0;
3143 while (nxt) {
3144 assign_svalue_no_free (&res->item[cnt2++], nxt->val);
3145 free_svalue(&nxt->mark);
3146 nxt = nxt->same;
3147 }
3148
3149 if (!head)
3150 break; /* It shouldn't but, to avoid skydive just in case */
3151 }
3152
3153 /* Cleanup using the cleanup structure */
3154 free_svalue(inter_sp--);
3155
3156 return ret;
3157 } /* make_unique() */
3158
3159 /*-------------------------------------------------------------------------*/
3160 svalue_t *
v_unique_array(svalue_t * sp,int num_arg)3161 v_unique_array (svalue_t *sp, int num_arg)
3162
3163 /* EFUN unique_array()
3164 *
3165 * mixed unique_array(object *obarr, string|closure fun)
3166 * mixed unique_array(object *obarr, string|closure fun, mixed skip)
3167 * mixed unique_array(object *obarr, string|closure fun, mixed extra..., mixed skip)
3168 *
3169 * Groups objects together for which the separator function
3170 * returns the same value. obarr should be an array of objects,
3171 * other types are ignored.
3172 *
3173 * If the separator function is defined by name, it is searched and called
3174 * in the objects from <obarr>. If <extra> arguments are given, they are
3175 * passed to the function as arguments.
3176 *
3177 * If the separator function is defined as a closure, it will be passed
3178 * the objects from <obarr> as first argument, with the <extra> arguments
3179 * (if any) passed following.
3180 *
3181 * If the <skip> argument is given (it is required when <extra> arguments
3182 * are to be used), and the return value from the separator function call
3183 * matches this value, the object in question will _not_ be included in the
3184 * returned array. Default value for <skip> is the number 0.
3185 */
3186
3187 {
3188 vector_t *res;
3189 svalue_t *argp = sp - num_arg + 1;
3190 callback_t cb; /* must persist until the end of the function */
3191
3192 check_for_destr(argp->u.vec);
3193
3194 /* Sort out the arguments */
3195 if (num_arg == 2)
3196 {
3197 /* Just the callback function name on the stack: add the default
3198 * 'skip' value
3199 */
3200 sp++;
3201 put_number(sp, 0);
3202 }
3203
3204 {
3205 /* Extract the callback information from the stack */
3206 int error_index;
3207
3208 assign_eval_cost();
3209 inter_sp = sp;
3210
3211 error_index = setup_efun_callback_noobj(&cb, argp+1, num_arg-2);
3212
3213 if (error_index >= 0)
3214 {
3215 /* The callback values have already been removed, now
3216 * make sure that the 'skip' value isn't left out either
3217 */
3218 transfer_svalue_no_free(argp+1, sp);
3219 inter_sp = sp = argp+1;
3220 vefun_bad_arg(error_index+2, argp+1);
3221 /* NOTREACHED */
3222 return argp;
3223 }
3224
3225 /* Callback creation successful, now setup the stack */
3226 put_callback(argp+1, &cb);
3227 transfer_svalue_no_free(argp+2, sp);
3228
3229 inter_sp = sp = argp+2;
3230 }
3231
3232 /* At this point: argp[0]: the vector
3233 * argp[1]: the callback structure
3234 * sp -> argp[2]: the skip value
3235 */
3236 res = make_unique(argp->u.vec, argp[1].u.cb, argp+2);
3237
3238 /* Clean up the stack and push the result */
3239 free_svalue(sp--);
3240 free_svalue(sp--);
3241 free_svalue(sp);
3242
3243 if (res)
3244 put_array(sp, res);
3245 else
3246 put_number(sp, 0);
3247
3248 return sp;
3249 } /* v_unique_array() */
3250
3251 /***************************************************************************/
3252
3253