1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2019 Thomas Mertes */
5 /* */
6 /* This program is free software; you can redistribute it and/or */
7 /* modify it under the terms of the GNU General Public License as */
8 /* published by the Free Software Foundation; either version 2 of */
9 /* the License, or (at your option) any later version. */
10 /* */
11 /* This program is distributed in the hope that it will be useful, */
12 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
13 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
14 /* GNU General Public License for more details. */
15 /* */
16 /* You should have received a copy of the GNU General Public */
17 /* License along with this program; if not, write to the */
18 /* Free Software Foundation, Inc., 51 Franklin Street, */
19 /* Fifth Floor, Boston, MA 02110-1301, USA. */
20 /* */
21 /* Module: Library */
22 /* File: seed7/src/arrlib.c */
23 /* Changes: 1993, 1994, 2013, 2015, 2016, 2019 Thomas Mertes */
24 /* Content: All primitive actions for array types. */
25 /* */
26 /********************************************************************/
27
28 #define LOG_FUNCTIONS 0
29 #define VERBOSE_EXCEPTIONS 0
30
31 #include "version.h"
32
33 #include "stdlib.h"
34 #include "stdio.h"
35 #include "string.h"
36
37 #include "common.h"
38 #include "data.h"
39 #include "heaputl.h"
40 #include "flistutl.h"
41 #include "syvarutl.h"
42 #include "traceutl.h"
43 #include "executl.h"
44 #include "objutl.h"
45 #include "runerr.h"
46
47 #undef EXTERN
48 #define EXTERN
49 #include "arrlib.h"
50
51
52 #define QSORT_LIMIT 8
53
54
55
56 /**
57 * Sort an array of 'objectRecord' elements with the quicksort algorithm.
58 * In contrast to qsort() this function uses a different compare function.
59 * The compare function of qsort() has two void pointers as parameters.
60 * @param begin_sort Pointer to first element to be sorted.
61 * @param end_sort Pointer to the last element to be sorted.
62 * @param cmp_func Object describing the compare function to be used.
63 */
qsort_array(objectType begin_sort,objectType end_sort,objectType cmp_func)64 static void qsort_array (objectType begin_sort, objectType end_sort,
65 objectType cmp_func)
66
67 {
68 objectRecord compare_elem;
69 objectRecord help_element;
70 objectType middle_elem;
71 objectType less_elem;
72 objectType greater_elem;
73 objectType cmp_obj;
74 intType cmp;
75
76 /* qsort_array */
77 if (end_sort - begin_sort < QSORT_LIMIT) {
78 /* Use insertion sort */
79 for (middle_elem = begin_sort + 1; middle_elem <= end_sort; middle_elem++) {
80 memcpy(&compare_elem, middle_elem, sizeof(objectRecord));
81 less_elem = begin_sort - 1;
82 do {
83 less_elem++;
84 cmp_obj = param3_call(cmp_func, less_elem, &compare_elem, cmp_func);
85 isit_int2(cmp_obj);
86 cmp = take_int(cmp_obj);
87 FREE_OBJECT(cmp_obj);
88 } while (cmp < 0);
89 memmove(&less_elem[1], less_elem,
90 (memSizeType) (middle_elem - less_elem) * sizeof(objectRecord));
91 memcpy(less_elem, &compare_elem, sizeof(objectRecord));
92 } /* for */
93 } else {
94 middle_elem = &begin_sort[(memSizeType) (end_sort - begin_sort) >> 1];
95 memcpy(&compare_elem, middle_elem, sizeof(objectRecord));
96 memcpy(middle_elem, end_sort, sizeof(objectRecord));
97 memcpy(end_sort, &compare_elem, sizeof(objectRecord));
98 less_elem = begin_sort - 1;
99 greater_elem = end_sort;
100 do {
101 do {
102 less_elem++;
103 cmp_obj = param3_call(cmp_func, less_elem, &compare_elem, cmp_func);
104 isit_int2(cmp_obj);
105 cmp = take_int(cmp_obj);
106 FREE_OBJECT(cmp_obj);
107 } while (cmp < 0);
108 do {
109 greater_elem--;
110 cmp_obj = param3_call(cmp_func, greater_elem, &compare_elem, cmp_func);
111 isit_int2(cmp_obj);
112 cmp = take_int(cmp_obj);
113 FREE_OBJECT(cmp_obj);
114 } while (cmp > 0 && greater_elem != begin_sort);
115 memcpy(&help_element, less_elem, sizeof(objectRecord));
116 memcpy(less_elem, greater_elem, sizeof(objectRecord));
117 memcpy(greater_elem, &help_element, sizeof(objectRecord));
118 } while (greater_elem > less_elem);
119 memcpy(greater_elem, less_elem, sizeof(objectRecord));
120 memcpy(less_elem, &compare_elem, sizeof(objectRecord));
121 memcpy(end_sort, &help_element, sizeof(objectRecord));
122 qsort_array(begin_sort, less_elem - 1, cmp_func);
123 qsort_array(less_elem + 1, end_sort, cmp_func);
124 } /* if */
125 } /* qsort_array */
126
127
128
129 /**
130 * Append the array 'extension' to the array 'arr_variable'.
131 * @exception MEMORY_ERROR Not enough memory for the concatenated
132 * array.
133 */
arr_append(listType arguments)134 objectType arr_append (listType arguments)
135
136 {
137 objectType arr_variable;
138 arrayType arr_to;
139 arrayType extension;
140 arrayType new_arr;
141 memSizeType new_size;
142 memSizeType arr_to_size;
143 memSizeType extension_size;
144
145 /* arr_append */
146 logFunction(printf("arr_append\n"););
147 arr_variable = arg_1(arguments);
148 isit_array(arr_variable);
149 is_variable(arr_variable);
150 arr_to = take_array(arr_variable);
151 isit_array(arg_3(arguments));
152 extension = take_array(arg_3(arguments));
153 extension_size = arraySize(extension);
154 if (extension_size != 0) {
155 arr_to_size = arraySize(arr_to);
156 if (unlikely(arr_to_size > MAX_ARR_LEN - extension_size ||
157 arr_to->max_position > (intType) (MAX_MEM_INDEX - extension_size))) {
158 return raise_exception(SYS_MEM_EXCEPTION);
159 } else {
160 new_size = arr_to_size + extension_size;
161 new_arr = REALLOC_ARRAY(arr_to, arr_to_size, new_size);
162 if (unlikely(new_arr == NULL)) {
163 return raise_exception(SYS_MEM_EXCEPTION);
164 } else {
165 COUNT3_ARRAY(arr_to_size, new_size);
166 arr_variable->value.arrayValue = new_arr;
167 if (TEMP_OBJECT(arg_3(arguments))) {
168 memcpy(&new_arr->arr[arr_to_size], extension->arr,
169 (size_t) (extension_size * sizeof(objectRecord)));
170 new_arr->max_position = arrayMaxPos(new_arr->min_position, new_size);
171 FREE_ARRAY(extension, extension_size);
172 arg_3(arguments)->value.arrayValue = NULL;
173 } else {
174 /* It is possible that arr_to == extension holds. */
175 /* In this case 'extension' must be corrected */
176 /* after realloc() enlarged 'arr_to'. */
177 if (arr_to == extension) {
178 extension = new_arr;
179 } /* if */
180 if (unlikely(!crea_array(&new_arr->arr[arr_to_size], extension->arr,
181 extension_size))) {
182 arr_to = REALLOC_ARRAY(new_arr, new_size, arr_to_size);
183 if (unlikely(arr_to == NULL)) {
184 return raise_exception(SYS_MEM_EXCEPTION);
185 } /* if */
186 COUNT3_ARRAY(new_size, arr_to_size);
187 arr_variable->value.arrayValue = arr_to;
188 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
189 } else {
190 new_arr->max_position = arrayMaxPos(new_arr->min_position, new_size);
191 } /* if */
192 } /* if */
193 } /* if */
194 } /* if */
195 } /* if */
196 logFunction(printf("arr_append -->\n"););
197 return SYS_EMPTY_OBJECT;
198 } /* arr_append */
199
200
201
202 /**
203 * Generate an array literal from a tuple.
204 */
arr_arrlit(listType arguments)205 objectType arr_arrlit (listType arguments)
206
207 {
208 objectType arr_arg;
209 arrayType arr1;
210 memSizeType result_size;
211 arrayType result_array;
212 objectType result;
213
214 /* arr_arrlit */
215 arr_arg = arg_3(arguments);
216 isit_array(arr_arg);
217 if (TEMP_OBJECT(arr_arg)) {
218 result = arr_arg;
219 result->type_of = NULL;
220 arg_3(arguments) = NULL;
221 } else {
222 arr1 = take_array(arr_arg);
223 result_size = arraySize(arr1);
224 if (unlikely(result_size > MAX_MEM_INDEX)) {
225 logError(printf("arr_arrlit(arr1 (size=" FMT_U_MEM ")): "
226 "Maximum index out of range.\n",
227 result_size););
228 return raise_exception(SYS_RNG_EXCEPTION);
229 } else if (unlikely(!ALLOC_ARRAY(result_array, result_size))) {
230 return raise_exception(SYS_MEM_EXCEPTION);
231 } else {
232 result_array->min_position = 1;
233 result_array->max_position = (intType) result_size;
234 if (unlikely(!crea_array(result_array->arr, arr1->arr, result_size))) {
235 FREE_ARRAY(result_array, result_size);
236 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
237 } else {
238 result = bld_array_temp(result_array);
239 } /* if */
240 } /* if */
241 } /* if */
242 return result;
243 } /* arr_arrlit */
244
245
246
arr_arrlit2(listType arguments)247 objectType arr_arrlit2 (listType arguments)
248
249 {
250 intType start_position;
251 objectType arr_arg;
252 arrayType arr1;
253 memSizeType result_size;
254 arrayType result_array;
255 objectType result;
256
257 /* arr_arrlit2 */
258 logFunction(printf("arr_arrlit2\n"););
259 isit_int(arg_2(arguments));
260 start_position = take_int(arg_2(arguments));
261 arr_arg = arg_4(arguments);
262 isit_array(arr_arg);
263 arr1 = take_array(arr_arg);
264 result_size = arraySize(arr1);
265 if (unlikely(start_position < MIN_MEM_INDEX ||
266 start_position > MAX_MEM_INDEX ||
267 (result_size != 0 &&
268 start_position > (intType) (MAX_MEM_INDEX - result_size + 1)) ||
269 (result_size == 0 && start_position == MIN_MEM_INDEX))) {
270 logError(printf("arr_arrlit2(" FMT_D ", arr1 (size=" FMT_U_MEM ")): "
271 "Minimum or maximum index out of range.\n",
272 start_position, result_size););
273 return raise_exception(SYS_RNG_EXCEPTION);
274 } else {
275 if (TEMP_OBJECT(arr_arg)) {
276 arr1->min_position = start_position;
277 arr1->max_position = arrayMaxPos(start_position, result_size);
278 result = arr_arg;
279 result->type_of = NULL;
280 arg_4(arguments) = NULL;
281 } else {
282 if (unlikely(!ALLOC_ARRAY(result_array, result_size))) {
283 return raise_exception(SYS_MEM_EXCEPTION);
284 } /* if */
285 result_array->min_position = start_position;
286 result_array->max_position = arrayMaxPos(start_position, result_size);
287 if (unlikely(!crea_array(result_array->arr, arr1->arr, result_size))) {
288 FREE_ARRAY(result_array, result_size);
289 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
290 } /* if */
291 result = bld_array_temp(result_array);
292 } /* if */
293 } /* if */
294 logFunction(printf("arr_arrlit2 -->\n"););
295 return result;
296 } /* arr_arrlit2 */
297
298
299
arr_baselit(listType arguments)300 objectType arr_baselit (listType arguments)
301
302 {
303 objectType element;
304 typeType result_element_type;
305 memSizeType result_size;
306 arrayType result;
307
308 /* arr_baselit */
309 element = arg_3(arguments);
310 result_size = 1;
311 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
312 return raise_exception(SYS_MEM_EXCEPTION);
313 } /* if */
314 result->min_position = 1;
315 result->max_position = 1;
316 /* The element type of the result is the type of the 3rd formal parameter */
317 result_element_type = curr_exec_object->value.listValue->obj->
318 descriptor.property->params->next->next->obj->type_of;
319 if (TEMP_OBJECT(element) && element->type_of == result_element_type) {
320 CLEAR_TEMP_FLAG(element);
321 SET_VAR_FLAG(element);
322 memcpy(&result->arr[0], element, sizeof(objectRecord));
323 FREE_OBJECT(element);
324 arg_3(arguments) = NULL;
325 } else {
326 if (unlikely(!arr_elem_initialisation(result_element_type,
327 &result->arr[0], element))) {
328 FREE_ARRAY(result, result_size);
329 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
330 } /* if */
331 } /* if */
332 return bld_array_temp(result);
333 } /* arr_baselit */
334
335
336
arr_baselit2(listType arguments)337 objectType arr_baselit2 (listType arguments)
338
339 {
340 intType start_position;
341 objectType element;
342 typeType result_element_type;
343 memSizeType result_size;
344 arrayType result;
345
346 /* arr_baselit2 */
347 isit_int(arg_2(arguments));
348 start_position = take_int(arg_2(arguments));
349 element = arg_4(arguments);
350 result_size = 1;
351 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
352 return raise_exception(SYS_MEM_EXCEPTION);
353 } /* if */
354 result->min_position = start_position;
355 result->max_position = start_position;
356 /* The element type of the result is the type of the 4th formal parameter */
357 result_element_type = curr_exec_object->value.listValue->obj->
358 descriptor.property->params->next->next->next->obj->type_of;
359 if (TEMP_OBJECT(element) && element->type_of == result_element_type) {
360 CLEAR_TEMP_FLAG(element);
361 SET_VAR_FLAG(element);
362 memcpy(&result->arr[0], element, sizeof(objectRecord));
363 FREE_OBJECT(element);
364 arg_4(arguments) = NULL;
365 } else {
366 if (unlikely(!arr_elem_initialisation(result_element_type,
367 &result->arr[0], element))) {
368 FREE_ARRAY(result, result_size);
369 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
370 } /* if */
371 } /* if */
372 return bld_array_temp(result);
373 } /* arr_baselit2 */
374
375
376
377 /**
378 * Concatenate two arrays.
379 * @return the result of the concatenation.
380 * @exception MEMORY_ERROR Not enough memory for the concatenated
381 * array.
382 */
arr_cat(listType arguments)383 objectType arr_cat (listType arguments)
384
385 {
386 arrayType arr1;
387 arrayType arr2;
388 memSizeType arr1_size;
389 memSizeType arr2_size;
390 memSizeType result_size;
391 arrayType result;
392
393 /* arr_cat */
394 isit_array(arg_1(arguments));
395 isit_array(arg_3(arguments));
396 arr1 = take_array(arg_1(arguments));
397 arr2 = take_array(arg_3(arguments));
398 arr1_size = arraySize(arr1);
399 arr2_size = arraySize(arr2);
400 if (unlikely(arr1_size > MAX_ARR_LEN - arr2_size ||
401 arr1->max_position > (intType) (MAX_MEM_INDEX - arr2_size))) {
402 return raise_exception(SYS_MEM_EXCEPTION);
403 } else {
404 result_size = arr1_size + arr2_size;
405 if (TEMP_OBJECT(arg_1(arguments))) {
406 result = arr1;
407 result = REALLOC_ARRAY(result, arr1_size, result_size);
408 if (unlikely(result == NULL)) {
409 return raise_exception(SYS_MEM_EXCEPTION);
410 } /* if */
411 COUNT3_ARRAY(arr1_size, result_size);
412 result->max_position = arrayMaxPos(result->min_position, result_size);
413 arg_1(arguments)->value.arrayValue = NULL;
414 } else {
415 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
416 return raise_exception(SYS_MEM_EXCEPTION);
417 } /* if */
418 result->min_position = arr1->min_position;
419 result->max_position = arrayMaxPos(result->min_position, result_size);
420 if (unlikely(!crea_array(result->arr, arr1->arr, arr1_size))) {
421 FREE_ARRAY(result, result_size);
422 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
423 } /* if */
424 } /* if */
425 if (TEMP_OBJECT(arg_3(arguments))) {
426 memcpy(&result->arr[arr1_size], arr2->arr,
427 (size_t) (arr2_size * sizeof(objectRecord)));
428 FREE_ARRAY(arr2, arr2_size);
429 arg_3(arguments)->value.arrayValue = NULL;
430 } else {
431 if (unlikely(!crea_array(&result->arr[arr1_size],
432 arr2->arr, arr2_size))) {
433 destr_array(result->arr, arr1_size);
434 FREE_ARRAY(result, result_size);
435 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
436 } /* if */
437 } /* if */
438 } /* if */
439 return bld_array_temp(result);
440 } /* arr_cat */
441
442
443
arr_conv(listType arguments)444 objectType arr_conv (listType arguments)
445
446 {
447 objectType arr_arg;
448 arrayType arr1;
449 memSizeType result_size;
450 arrayType result;
451
452 /* arr_conv */
453 arr_arg = arg_3(arguments);
454 isit_array(arr_arg);
455 if (TEMP_OBJECT(arr_arg)) {
456 result = take_array(arr_arg);
457 arr_arg->value.arrayValue = NULL;
458 return bld_array_temp(result);
459 } else if (VAR_OBJECT(arr_arg)) {
460 return arr_arg;
461 } else {
462 arr1 = take_array(arr_arg);
463 result_size = arraySize(arr1);
464 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
465 return raise_exception(SYS_MEM_EXCEPTION);
466 } /* if */
467 result->min_position = arr1->min_position;
468 result->max_position = arr1->max_position;
469 if (unlikely(!crea_array(result->arr, arr1->arr, result_size))) {
470 FREE_ARRAY(result, result_size);
471 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
472 } /* if */
473 return bld_array_temp(result);
474 } /* if */
475 } /* arr_conv */
476
477
478
479 /**
480 * Assign source/arg_3 to dest/arg_1.
481 * A copy function assumes that dest/arg_1 contains a legal value.
482 */
arr_cpy(listType arguments)483 objectType arr_cpy (listType arguments)
484
485 {
486 objectType dest;
487 objectType source;
488 arrayType arr_dest;
489 arrayType arr_source;
490 memSizeType arr_dest_size;
491 memSizeType arr_source_size;
492 arrayType new_arr;
493
494 /* arr_cpy */
495 dest = arg_1(arguments);
496 source = arg_3(arguments);
497 isit_array(dest);
498 isit_array(source);
499 is_variable(dest);
500 arr_dest = take_array(dest);
501 arr_source = take_array(source);
502 if (TEMP_OBJECT(source)) {
503 arr_dest_size = arraySize(arr_dest);
504 destr_array(arr_dest->arr, arr_dest_size);
505 FREE_ARRAY(arr_dest, arr_dest_size);
506 dest->value.arrayValue = arr_source;
507 source->value.arrayValue = NULL;
508 } else {
509 arr_source_size = arraySize(arr_source);
510 if (arr_dest->min_position != arr_source->min_position ||
511 arr_dest->max_position != arr_source->max_position) {
512 if (unlikely(!ALLOC_ARRAY(new_arr, arr_source_size))) {
513 return raise_exception(SYS_MEM_EXCEPTION);
514 } else {
515 new_arr->min_position = arr_source->min_position;
516 new_arr->max_position = arr_source->max_position;
517 if (unlikely(!crea_array(new_arr->arr,
518 arr_source->arr, arr_source_size))) {
519 FREE_ARRAY(new_arr, arr_source_size);
520 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
521 } /* if */
522 arr_dest_size = arraySize(arr_dest);
523 destr_array(arr_dest->arr, arr_dest_size);
524 FREE_ARRAY(arr_dest, arr_dest_size);
525 dest->value.arrayValue = new_arr;
526 } /* if */
527 } else {
528 cpy_array(arr_dest->arr, arr_source->arr, arr_source_size);
529 } /* if */
530 } /* if */
531 return SYS_EMPTY_OBJECT;
532 } /* arr_cpy */
533
534
535
536 /**
537 * Initialize dest/arg_1 and assign source/arg_3 to it.
538 * A create function assumes that the contents of dest/arg_1
539 * is undefined. Create functions can be used to initialize
540 * constants.
541 */
arr_create(listType arguments)542 objectType arr_create (listType arguments)
543
544 {
545 objectType dest;
546 objectType source;
547 arrayType arr_source;
548 memSizeType new_size;
549 arrayType new_arr;
550
551 /* arr_create */
552 dest = arg_1(arguments);
553 source = arg_3(arguments);
554 isit_array(source);
555 arr_source = take_array(source);
556 SET_CATEGORY_OF_OBJ(dest, ARRAYOBJECT);
557 if (TEMP_OBJECT(source)) {
558 dest->value.arrayValue = arr_source;
559 source->value.arrayValue = NULL;
560 } else {
561 new_size = arraySize(arr_source);
562 if (unlikely(!ALLOC_ARRAY(new_arr, new_size))) {
563 dest->value.arrayValue = NULL;
564 return raise_exception(SYS_MEM_EXCEPTION);
565 } else {
566 new_arr->min_position = arr_source->min_position;
567 new_arr->max_position = arr_source->max_position;
568 if (unlikely(!crea_array(new_arr->arr,
569 arr_source->arr, new_size))) {
570 FREE_ARRAY(new_arr, new_size);
571 dest->value.arrayValue = NULL;
572 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
573 } /* if */
574 dest->value.arrayValue = new_arr;
575 } /* if */
576 } /* if */
577 return SYS_EMPTY_OBJECT;
578 } /* arr_create */
579
580
581
582 /**
583 * Free the memory referred by 'old_arr/arg_1'.
584 * After arr_destr is left 'old_arr/arg_1' is NULL.
585 * The memory where 'old_arr/arg_1' is stored can be freed afterwards.
586 */
arr_destr(listType arguments)587 objectType arr_destr (listType arguments)
588
589 {
590 arrayType old_arr;
591 memSizeType old_size;
592
593 /* arr_destr */
594 isit_array(arg_1(arguments));
595 old_arr = take_array(arg_1(arguments));
596 if (old_arr != NULL) {
597 old_size = arraySize(old_arr);
598 destr_array(old_arr->arr, old_size);
599 FREE_ARRAY(old_arr, old_size);
600 arg_1(arguments)->value.arrayValue = NULL;
601 } /* if */
602 SET_UNUSED_FLAG(arg_1(arguments));
603 return SYS_EMPTY_OBJECT;
604 } /* arr_destr */
605
606
607
608 /**
609 * Get an empty array (an array without elements).
610 * @return an empty array.
611 * @exception MEMORY_ERROR Not enough memory to represent the result.
612 */
arr_empty(listType arguments)613 objectType arr_empty (listType arguments)
614
615 {
616 arrayType result;
617
618 /* arr_empty */
619 if (unlikely(!ALLOC_ARRAY(result, 0))) {
620 return raise_exception(SYS_MEM_EXCEPTION);
621 } else {
622 /* Note that the size of the allocated memory is smaller, than the */
623 /* struct. But this is okay, because the element 'arr' is not used. */
624 result->min_position = 1;
625 result->max_position = 0;
626 } /* if */
627 return bld_array_temp(result);
628 } /* arr_empty */
629
630
631
arr_extend(listType arguments)632 objectType arr_extend (listType arguments)
633
634 {
635 arrayType arr1;
636 objectType element;
637 typeType result_element_type;
638 memSizeType arr1_size;
639 memSizeType result_size;
640 arrayType result;
641
642 /* arr_extend */
643 isit_array(arg_1(arguments));
644 arr1 = take_array(arg_1(arguments));
645 element = arg_3(arguments);
646 arr1_size = arraySize(arr1);
647 if (unlikely(arr1_size > MAX_ARR_LEN - 1 ||
648 arr1->max_position > (intType) (MAX_MEM_INDEX - 1))) {
649 return raise_exception(SYS_MEM_EXCEPTION);
650 } else {
651 result_size = arr1_size + 1;
652 if (TEMP_OBJECT(arg_1(arguments))) {
653 result = arr1;
654 result = REALLOC_ARRAY(result, arr1_size, result_size);
655 if (unlikely(result == NULL)) {
656 return raise_exception(SYS_MEM_EXCEPTION);
657 } /* if */
658 COUNT3_ARRAY(arr1_size, result_size);
659 result->max_position++;
660 arg_1(arguments)->value.arrayValue = NULL;
661 } else {
662 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
663 return raise_exception(SYS_MEM_EXCEPTION);
664 } /* if */
665 result->min_position = arr1->min_position;
666 result->max_position = arr1->max_position + 1;
667 if (unlikely(!crea_array(result->arr, arr1->arr, arr1_size))) {
668 FREE_ARRAY(result, result_size);
669 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
670 } /* if */
671 } /* if */
672 /* The element type of the result is the type of the 3rd formal parameter */
673 result_element_type = curr_exec_object->value.listValue->obj->
674 descriptor.property->params->next->next->obj->type_of;
675 if (TEMP_OBJECT(element) && element->type_of == result_element_type) {
676 CLEAR_TEMP_FLAG(element);
677 SET_VAR_FLAG(element);
678 memcpy(&result->arr[arr1_size], element, sizeof(objectRecord));
679 FREE_OBJECT(element);
680 arg_3(arguments) = NULL;
681 } else {
682 if (unlikely(!arr_elem_initialisation(result_element_type,
683 &result->arr[arr1_size], element))) {
684 destr_array(result->arr, arr1_size);
685 FREE_ARRAY(result, result_size);
686 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
687 } /* if */
688 } /* if */
689 } /* if */
690 return bld_array_temp(result);
691 } /* arr_extend */
692
693
694
arr_gen(listType arguments)695 objectType arr_gen (listType arguments)
696
697 {
698 objectType element1;
699 objectType element2;
700 typeType result_element_type;
701 memSizeType result_size;
702 arrayType result;
703
704 /* arr_gen */
705 element1 = arg_1(arguments);
706 element2 = arg_3(arguments);
707 result_size = 2;
708 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
709 return raise_exception(SYS_MEM_EXCEPTION);
710 } /* if */
711 result->min_position = 1;
712 result->max_position = 2;
713 /* The element type of the result is the type of the 1st formal parameter */
714 result_element_type = curr_exec_object->value.listValue->obj->
715 descriptor.property->params->obj->type_of;
716 if (TEMP_OBJECT(element1) && element1->type_of == result_element_type) {
717 CLEAR_TEMP_FLAG(element1);
718 SET_VAR_FLAG(element1);
719 memcpy(&result->arr[0], element1, sizeof(objectRecord));
720 FREE_OBJECT(element1);
721 arg_1(arguments) = NULL;
722 } else {
723 if (unlikely(!arr_elem_initialisation(result_element_type,
724 &result->arr[0], element1))) {
725 FREE_ARRAY(result, result_size);
726 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
727 } /* if */
728 } /* if */
729 if (TEMP_OBJECT(element2) && element2->type_of == result_element_type) {
730 CLEAR_TEMP_FLAG(element2);
731 SET_VAR_FLAG(element2);
732 memcpy(&result->arr[1], element2, sizeof(objectRecord));
733 FREE_OBJECT(element2);
734 arg_3(arguments) = NULL;
735 } else {
736 if (unlikely(!arr_elem_initialisation(result_element_type,
737 &result->arr[1], element2))) {
738 destr_array(result->arr, (memSizeType) 1);
739 FREE_ARRAY(result, result_size);
740 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
741 } /* if */
742 } /* if */
743 return bld_array_temp(result);
744 } /* arr_gen */
745
746
747
748 /**
749 * Get a sub array ending at the position 'stop'.
750 * @return the sub array ending at the stop position.
751 * @exception INDEX_ERROR The stop position is less than pred(minIdx(arr1)).
752 * @exception MEMORY_ERROR Not enough memory to represent the result.
753 */
arr_head(listType arguments)754 objectType arr_head (listType arguments)
755
756 {
757 arrayType arr1;
758 intType stop;
759 memSizeType arr1_size;
760 memSizeType result_size;
761 arrayType resized_result;
762 arrayType result;
763
764 /* arr_head */
765 isit_array(arg_1(arguments));
766 isit_int(arg_4(arguments));
767 arr1 = take_array(arg_1(arguments));
768 stop = take_int(arg_4(arguments));
769 arr1_size = arraySize(arr1);
770 if (stop >= arr1->min_position && arr1_size >= 1) {
771 if (stop > arr1->max_position) {
772 stop = arr1->max_position;
773 } /* if */
774 result_size = arraySize2(arr1->min_position, stop);
775 if (TEMP_OBJECT(arg_1(arguments))) {
776 result = arr1;
777 arg_1(arguments)->value.arrayValue = NULL;
778 destr_array(&result->arr[result_size], arr1_size - result_size);
779 resized_result = REALLOC_ARRAY(result, arr1_size, result_size);
780 if (unlikely(resized_result == NULL)) {
781 destr_array(result->arr, result_size);
782 FREE_ARRAY(result, arr1_size);
783 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
784 } /* if */
785 result = resized_result;
786 COUNT3_ARRAY(arr1_size, result_size);
787 result->max_position = stop;
788 } else {
789 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
790 return raise_exception(SYS_MEM_EXCEPTION);
791 } /* if */
792 result->min_position = arr1->min_position;
793 result->max_position = stop;
794 if (unlikely(!crea_array(result->arr, arr1->arr, result_size))) {
795 FREE_ARRAY(result, result_size);
796 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
797 } /* if */
798 } /* if */
799 } else if (unlikely(stop < arr1->min_position - 1)) {
800 return raise_exception(SYS_IDX_EXCEPTION);
801 } else if (unlikely(arr1->min_position == MIN_MEM_INDEX)) {
802 logError(printf("arr_head(arr1 (size=" FMT_U_MEM "), " FMT_D "): "
803 "Cannot create empty array with minimum index.\n",
804 arr1_size, stop););
805 return raise_exception(SYS_RNG_EXCEPTION);
806 } else {
807 if (unlikely(!ALLOC_ARRAY(result, 0))) {
808 return raise_exception(SYS_MEM_EXCEPTION);
809 } /* if */
810 result->min_position = arr1->min_position;
811 result->max_position = arr1->min_position - 1;
812 } /* if */
813 return bld_array_temp(result);
814 } /* arr_head */
815
816
817
818 /**
819 * Access one element from the array 'arr'.
820 * @return the element with the specified 'position' from 'arr'.
821 * @exception INDEX_ERROR If 'position' is less than arr_minidx(arr) or
822 * greater than arr_maxidx(arr)
823 */
arr_idx(listType arguments)824 objectType arr_idx (listType arguments)
825
826 {
827 arrayType arr1;
828 intType position;
829 objectType array_pointer;
830 objectType result;
831
832 /* arr_idx */
833 logFunction(printf("arr_idx\n"););
834 isit_array(arg_1(arguments));
835 isit_int(arg_3(arguments));
836 arr1 = take_array(arg_1(arguments));
837 position = take_int(arg_3(arguments));
838 if (unlikely(position < arr1->min_position ||
839 position > arr1->max_position)) {
840 logError(printf("arr_idx(arr1, " FMT_D "): "
841 "Index out of range (" FMT_D " .. " FMT_D ").\n",
842 position, arr1->min_position, arr1->max_position););
843 result = raise_exception(SYS_IDX_EXCEPTION);
844 } else {
845 array_pointer = arr1->arr;
846 if (TEMP_OBJECT(arg_1(arguments))) {
847 /* The array will be destroyed after indexing. */
848 /* A copy is necessary here to avoid a crash !!!!! */
849 if (unlikely(!ALLOC_OBJECT(result))) {
850 result = raise_exception(SYS_MEM_EXCEPTION);
851 } else {
852 memcpy(result, &array_pointer[position - arr1->min_position], sizeof(objectRecord));
853 SET_TEMP_FLAG(result);
854 destr_array(array_pointer, arraySize2(arr1->min_position, position) - 1);
855 destr_array(&array_pointer[position - arr1->min_position + 1],
856 arraySize2(position, arr1->max_position) - 1);
857 FREE_ARRAY(arr1, arraySize(arr1));
858 arg_1(arguments)->value.arrayValue = NULL;
859 /* code to avoid destr_array:
860 if (position != arr1->max_position) {
861 memcpy(&array_pointer[position - arr1->min_position],
862 &array_pointer[arr1->max_position - arr1->min_position],
863 sizeof(objectRecord));
864 }
865 arr1->max_position--; */
866 } /* if */
867 } else {
868 /* This is the normal case: The array will exist after indexing. */
869 result = &array_pointer[position - arr1->min_position];
870 } /* if */
871 } /* if */
872 logFunction(printf("arr_idx --> " F_U_MEM(08) " ", (memSizeType) result);
873 trace1(result);
874 printf("\n"););
875 return result;
876 } /* arr_idx */
877
878
879
880 /**
881 * Insert 'element' at 'position' into 'arr1'.
882 * @exception INDEX_ERROR If 'position' is less than minIdx(arr1) or
883 * greater than succ(maxIdx(arr1))
884 */
arr_insert(listType arguments)885 objectType arr_insert (listType arguments)
886
887 {
888 arrayType arr1;
889 arrayType resized_arr1;
890 intType position;
891 typeType element_type;
892 objectType element;
893 objectRecord elementStore;
894 objectType array_pointer;
895 memSizeType arr1_size;
896 objectType result;
897
898 /* arr_insert */
899 logFunction(printf("arr_insert\n"););
900 isit_array(arg_1(arguments));
901 isit_int(arg_2(arguments));
902 is_variable(arg_1(arguments));
903 arr1 = take_array(arg_1(arguments));
904 position = take_int(arg_2(arguments));
905 element = arg_3(arguments);
906 if (unlikely(position < arr1->min_position ||
907 position > arr1->max_position + 1)) {
908 logError(printf("arr_insert(arr1, " FMT_D "): "
909 "Index out of range (" FMT_D " .. " FMT_D ").\n",
910 position, arr1->min_position, arr1->max_position + 1););
911 result = raise_exception(SYS_IDX_EXCEPTION);
912 } else {
913 /* The element type is the type of the 3rd formal parameter */
914 element_type = curr_exec_object->value.listValue->obj->
915 descriptor.property->params->next->next->obj->type_of;
916 if (unlikely(!arr_elem_initialisation(element_type,
917 &elementStore, element))) {
918 result = raise_exception(SYS_MEM_EXCEPTION);
919 } else {
920 arr1_size = arraySize(arr1);
921 resized_arr1 = REALLOC_ARRAY(arr1, arr1_size, arr1_size + 1);
922 if (unlikely(resized_arr1 == NULL)) {
923 result = raise_exception(SYS_MEM_EXCEPTION);
924 } else {
925 arr1 = resized_arr1;
926 COUNT3_ARRAY(arr1_size, arr1_size - 1);
927 array_pointer = arr1->arr;
928 memmove(&array_pointer[position - arr1->min_position + 1],
929 &array_pointer[position - arr1->min_position],
930 arraySize2(position, arr1->max_position) * sizeof(objectRecord));
931 memcpy(&array_pointer[position - arr1->min_position], &elementStore,
932 sizeof(objectRecord));
933 arr1->max_position++;
934 arg_1(arguments)->value.arrayValue = arr1;
935 result = SYS_EMPTY_OBJECT;
936 } /* if */
937 } /* if */
938 } /* if */
939 logFunction(printf("arr_insert -->\n"););
940 return result;
941 } /* arr_insert */
942
943
944
945 /**
946 * Insert 'elements' at 'position' into 'arr1'.
947 * @exception INDEX_ERROR If 'position' is less than minIdx(arr1) or
948 * greater than succ(maxIdx(arr1))
949 */
arr_insert_array(listType arguments)950 objectType arr_insert_array (listType arguments)
951
952 {
953 objectType arr_variable;
954 arrayType arr1;
955 arrayType resized_arr1;
956 intType position;
957 arrayType elements;
958 objectType array_pointer;
959 memSizeType new_size;
960 memSizeType arr1_size;
961 memSizeType elements_size;
962 boolType restore = FALSE;
963
964 /* arr_insert_array */
965 logFunction(printf("arr_insert_array\n"););
966 arr_variable = arg_1(arguments);
967 isit_array(arr_variable);
968 is_variable(arr_variable);
969 arr1 = take_array(arr_variable);
970 isit_int(arg_2(arguments));
971 isit_array(arg_3(arguments));
972 position = take_int(arg_2(arguments));
973 elements = take_array(arg_3(arguments));
974 elements_size = arraySize(elements);
975 if (unlikely(position < arr1->min_position ||
976 position > arr1->max_position + 1)) {
977 logError(printf("arr_insert(arr1, " FMT_D "): "
978 "Index out of range (" FMT_D " .. " FMT_D ").\n",
979 position, arr1->min_position, arr1->max_position + 1););
980 return raise_exception(SYS_IDX_EXCEPTION);
981 } else if (elements_size != 0) {
982 arr1_size = arraySize(arr1);
983 if (unlikely(arr1_size > MAX_ARR_LEN - elements_size ||
984 arr1->max_position > (intType) (MAX_MEM_INDEX - elements_size))) {
985 return raise_exception(SYS_MEM_EXCEPTION);
986 } else {
987 new_size = arr1_size + elements_size;
988 resized_arr1 = REALLOC_ARRAY(arr1, arr1_size, new_size);
989 if (unlikely(resized_arr1 == NULL)) {
990 return raise_exception(SYS_MEM_EXCEPTION);
991 } else {
992 COUNT3_ARRAY(arr1_size, new_size);
993 arr_variable->value.arrayValue = resized_arr1;
994 array_pointer = resized_arr1->arr;
995 memmove(&array_pointer[arrayIndex(resized_arr1, position) + elements_size],
996 &array_pointer[arrayIndex(resized_arr1, position)],
997 arraySize2(position, resized_arr1->max_position) * sizeof(objectRecord));
998 if (TEMP_OBJECT(arg_3(arguments))) {
999 memcpy(&array_pointer[arrayIndex(resized_arr1, position)], elements->arr,
1000 (size_t) (elements_size * sizeof(objectRecord)));
1001 resized_arr1->max_position = arrayMaxPos(resized_arr1->min_position, new_size);
1002 FREE_ARRAY(elements, elements_size);
1003 arg_3(arguments)->value.arrayValue = NULL;
1004 } else {
1005 /* It is possible that arr1 == elements holds. */
1006 /* In this case the new hole in arr1 must be */
1007 /* considered. */
1008 if (unlikely(arr1 == elements)) {
1009 if (unlikely(!crea_array(&array_pointer[arrayIndex(resized_arr1, position)],
1010 array_pointer, arrayIndex(resized_arr1, position)))) {
1011 restore = TRUE;
1012 } else {
1013 if (unlikely(!crea_array(&array_pointer[2 * arrayIndex(resized_arr1, position)],
1014 &array_pointer[arrayIndex(resized_arr1, position) + elements_size],
1015 elements_size - arrayIndex(resized_arr1, position)))) {
1016 destr_array(&array_pointer[arrayIndex(resized_arr1, position)],
1017 arrayIndex(resized_arr1, position));
1018 restore = TRUE;
1019 } /* if */
1020 } /* if */
1021 } else if (unlikely(!crea_array(&array_pointer[arrayIndex(resized_arr1, position)],
1022 elements->arr, elements_size))) {
1023 restore = TRUE;
1024 } /* if */
1025 if (unlikely(restore)) {
1026 memmove(&array_pointer[arrayIndex(resized_arr1, position)],
1027 &array_pointer[arrayIndex(resized_arr1, position) + elements_size],
1028 arraySize2(position, resized_arr1->max_position) * sizeof(objectRecord));
1029 arr1 = REALLOC_ARRAY(resized_arr1, new_size, arr1_size);
1030 if (unlikely(arr1 == NULL)) {
1031 return raise_exception(SYS_MEM_EXCEPTION);
1032 } /* if */
1033 COUNT3_ARRAY(new_size, arr1_size);
1034 arr_variable->value.arrayValue = arr1;
1035 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1036 } else {
1037 resized_arr1->max_position = arrayMaxPos(resized_arr1->min_position, new_size);
1038 } /* if */
1039 } /* if */
1040 } /* if */
1041 } /* if */
1042 } /* if */
1043 logFunction(printf("arr_insert_array -->\n"););
1044 return SYS_EMPTY_OBJECT;
1045 } /* arr_insert_array */
1046
1047
1048
1049 /**
1050 * Determine the length of the array 'arr'.
1051 * @return the length of the array.
1052 */
arr_lng(listType arguments)1053 objectType arr_lng (listType arguments)
1054
1055 {
1056 arrayType arr1;
1057
1058 /* arr_lng */
1059 isit_array(arg_1(arguments));
1060 arr1 = take_array(arg_1(arguments));
1061 return bld_int_temp(arr1->max_position - arr1->min_position + 1);
1062 } /* arr_lng */
1063
1064
1065
1066 /**
1067 * Maximum index of array 'arr'.
1068 * @return the maximum index of the array.
1069 */
arr_maxidx(listType arguments)1070 objectType arr_maxidx (listType arguments)
1071
1072 {
1073 arrayType arr1;
1074
1075 /* arr_maxidx */
1076 isit_array(arg_1(arguments));
1077 arr1 = take_array(arg_1(arguments));
1078 return bld_int_temp(arr1->max_position);
1079 } /* arr_maxidx */
1080
1081
1082
1083 /**
1084 * Minimum index of array 'arr'.
1085 * @return the minimum index of the array.
1086 */
arr_minidx(listType arguments)1087 objectType arr_minidx (listType arguments)
1088
1089 {
1090 arrayType arr1;
1091
1092 /* arr_minidx */
1093 isit_array(arg_1(arguments));
1094 arr1 = take_array(arg_1(arguments));
1095 return bld_int_temp(arr1->min_position);
1096 } /* arr_minidx */
1097
1098
1099
1100 /**
1101 * Append the given 'element' to the array 'arr_variable'.
1102 * @exception MEMORY_ERROR Not enough memory for the concatenated
1103 * array.
1104 */
arr_push(listType arguments)1105 objectType arr_push (listType arguments)
1106
1107 {
1108 objectType arr_variable;
1109 arrayType dest;
1110 objectType element;
1111 typeType result_element_type;
1112 arrayType new_arr;
1113 memSizeType new_size;
1114 memSizeType dest_size;
1115
1116 /* arr_push */
1117 logFunction(printf("arr_push\n"););
1118 arr_variable = arg_1(arguments);
1119 isit_array(arr_variable);
1120 is_variable(arr_variable);
1121 dest = take_array(arr_variable);
1122 element = arg_3(arguments);
1123 dest_size = arraySize(dest);
1124 if (unlikely(dest_size > MAX_ARR_LEN - 1 ||
1125 dest->max_position > (intType) (MAX_MEM_INDEX - 1))) {
1126 return raise_exception(SYS_MEM_EXCEPTION);
1127 } else {
1128 new_size = dest_size + 1;
1129 new_arr = REALLOC_ARRAY(dest, dest_size, new_size);
1130 if (unlikely(new_arr == NULL)) {
1131 return raise_exception(SYS_MEM_EXCEPTION);
1132 } else {
1133 COUNT3_ARRAY(dest_size, new_size);
1134 arr_variable->value.arrayValue = new_arr;
1135 /* The element type of the result is the type of the 3rd formal parameter */
1136 result_element_type = curr_exec_object->value.listValue->obj->
1137 descriptor.property->params->next->next->obj->type_of;
1138 if (TEMP_OBJECT(element) && element->type_of == result_element_type) {
1139 CLEAR_TEMP_FLAG(element);
1140 SET_VAR_FLAG(element);
1141 memcpy(&new_arr->arr[dest_size], element, sizeof(objectRecord));
1142 new_arr->max_position ++;
1143 FREE_OBJECT(element);
1144 arg_3(arguments) = NULL;
1145 } else {
1146 if (unlikely(!arr_elem_initialisation(result_element_type,
1147 &new_arr->arr[dest_size], element))) {
1148 dest = REALLOC_ARRAY(new_arr, new_size, dest_size);
1149 if (unlikely(dest == NULL)) {
1150 return raise_exception(SYS_MEM_EXCEPTION);
1151 } /* if */
1152 COUNT3_ARRAY(new_size, dest_size);
1153 arr_variable->value.arrayValue = dest;
1154 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1155 } else {
1156 new_arr->max_position ++;
1157 } /* if */
1158 } /* if */
1159 } /* if */
1160 } /* if */
1161 logFunction(printf("arr_push -->\n"););
1162 return SYS_EMPTY_OBJECT;
1163 } /* arr_push */
1164
1165
1166
1167 /**
1168 * Get a sub array from the position 'start' to the position 'stop'.
1169 * @return the sub array from position 'start' to 'stop'.
1170 * @exception INDEX_ERROR The start position is less than minIdx(arr1), or
1171 * the stop position is less than pred(start).
1172 * @exception MEMORY_ERROR Not enough memory to represent the result.
1173 */
arr_range(listType arguments)1174 objectType arr_range (listType arguments)
1175
1176 {
1177 arrayType arr1;
1178 intType start;
1179 intType stop;
1180 memSizeType arr1_size;
1181 memSizeType result_size;
1182 memSizeType start_idx;
1183 memSizeType stop_idx;
1184 arrayType result;
1185
1186 /* arr_range */
1187 isit_array(arg_1(arguments));
1188 isit_int(arg_3(arguments));
1189 isit_int(arg_5(arguments));
1190 arr1 = take_array(arg_1(arguments));
1191 start = take_int(arg_3(arguments));
1192 stop = take_int(arg_5(arguments));
1193 arr1_size = arraySize(arr1);
1194 if (unlikely(start < arr1->min_position)) {
1195 return raise_exception(SYS_IDX_EXCEPTION);
1196 } else if (stop >= start && start <= arr1->max_position && arr1_size >= 1) {
1197 if (stop > arr1->max_position) {
1198 stop = arr1->max_position;
1199 } /* if */
1200 result_size = arraySize2(start, stop);
1201 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1202 return raise_exception(SYS_MEM_EXCEPTION);
1203 } /* if */
1204 result->min_position = arr1->min_position;
1205 result->max_position = arrayMaxPos(arr1->min_position, result_size);
1206 start_idx = arrayIndex(arr1, start);
1207 stop_idx = arrayIndex(arr1, stop);
1208 if (TEMP_OBJECT(arg_1(arguments))) {
1209 memcpy(result->arr, &arr1->arr[start_idx],
1210 (size_t) (result_size * sizeof(objectRecord)));
1211 destr_array(arr1->arr, start_idx);
1212 destr_array(&arr1->arr[stop_idx + 1], arr1_size - stop_idx - 1);
1213 FREE_ARRAY(arr1, arr1_size);
1214 arg_1(arguments)->value.arrayValue = NULL;
1215 } else {
1216 if (unlikely(!crea_array(result->arr,
1217 &arr1->arr[start_idx], result_size))) {
1218 FREE_ARRAY(result, result_size);
1219 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1220 } /* if */
1221 } /* if */
1222 } else if (unlikely(stop < start - 1)) {
1223 return raise_exception(SYS_IDX_EXCEPTION);
1224 } else if (unlikely(arr1->min_position == MIN_MEM_INDEX)) {
1225 logError(printf("arr_range(arr1 (size=" FMT_U_MEM "), " FMT_D ", " FMT_D "): "
1226 "Cannot create empty array with minimum index.\n",
1227 arr1_size, start, stop););
1228 return raise_exception(SYS_RNG_EXCEPTION);
1229 } else {
1230 if (unlikely(!ALLOC_ARRAY(result, 0))) {
1231 return raise_exception(SYS_MEM_EXCEPTION);
1232 } /* if */
1233 result->min_position = arr1->min_position;
1234 result->max_position = arr1->min_position - 1;
1235 } /* if */
1236 return bld_array_temp(result);
1237 } /* arr_range */
1238
1239
1240
1241 /**
1242 * Remove the element with 'position' from 'arr1' and return the removed element.
1243 * @return the removed element.
1244 * @exception INDEX_ERROR If 'position' is less than arr_minidx(arr2) or
1245 * greater than arr_maxidx(arr2)
1246 */
arr_remove(listType arguments)1247 objectType arr_remove (listType arguments)
1248
1249 {
1250 arrayType arr1;
1251 arrayType resized_arr1;
1252 intType position;
1253 objectType array_pointer;
1254 memSizeType arr1_size;
1255 objectType result;
1256
1257 /* arr_remove */
1258 logFunction(printf("arr_remove\n"););
1259 isit_array(arg_1(arguments));
1260 isit_int(arg_2(arguments));
1261 is_variable(arg_1(arguments));
1262 arr1 = take_array(arg_1(arguments));
1263 position = take_int(arg_2(arguments));
1264 if (unlikely(position < arr1->min_position ||
1265 position > arr1->max_position)) {
1266 logError(printf("arr_remove(arr1, " FMT_D "): "
1267 "Index out of range (" FMT_D " .. " FMT_D ").\n",
1268 position, arr1->min_position, arr1->max_position););
1269 result = raise_exception(SYS_IDX_EXCEPTION);
1270 } else {
1271 array_pointer = arr1->arr;
1272 if (unlikely(!ALLOC_OBJECT(result))) {
1273 result = raise_exception(SYS_MEM_EXCEPTION);
1274 } else {
1275 memcpy(result, &array_pointer[position - arr1->min_position], sizeof(objectRecord));
1276 memmove(&array_pointer[position - arr1->min_position],
1277 &array_pointer[position - arr1->min_position + 1],
1278 (arraySize2(position, arr1->max_position) - 1) * sizeof(objectRecord));
1279 arr1_size = arraySize(arr1);
1280 resized_arr1 = REALLOC_ARRAY(arr1, arr1_size, arr1_size - 1);
1281 if (unlikely(resized_arr1 == NULL)) {
1282 /* A realloc, which shrinks memory, usually succeeds. */
1283 /* The probability that this code path is executed is */
1284 /* probably zero. The code below restores the old */
1285 /* value of arr1. */
1286 memmove(&array_pointer[position - arr1->min_position + 1],
1287 &array_pointer[position - arr1->min_position],
1288 (arraySize2(position, arr1->max_position) - 1) * sizeof(objectRecord));
1289 memcpy(&array_pointer[position - arr1->min_position], result, sizeof(objectRecord));
1290 FREE_OBJECT(result);
1291 result = raise_exception(SYS_MEM_EXCEPTION);
1292 } else {
1293 arr1 = resized_arr1;
1294 COUNT3_ARRAY(arr1_size, arr1_size - 1);
1295 arr1->max_position--;
1296 arg_1(arguments)->value.arrayValue = arr1;
1297 SET_TEMP_FLAG(result);
1298 } /* if */
1299 } /* if */
1300 } /* if */
1301 logFunction(printf("arr_remove --> " F_U_MEM(08) " ", (memSizeType) result);
1302 trace1(result);
1303 printf("\n"););
1304 return result;
1305 } /* arr_remove */
1306
1307
1308
1309 /**
1310 * Remove the sub-array with 'position' and 'length' from 'arr1'.
1311 * @return the removed sub-array.
1312 * @exception INDEX_ERROR If 'position' is less than arr_minidx(arr2) or
1313 * greater than arr_maxidx(arr2)
1314 */
arr_remove_array(listType arguments)1315 objectType arr_remove_array (listType arguments)
1316
1317 {
1318 arrayType arr1;
1319 arrayType resized_arr1;
1320 intType position;
1321 intType length;
1322 objectType array_pointer;
1323 memSizeType arr1_size;
1324 memSizeType result_size;
1325 arrayType result;
1326
1327 /* arr_remove_array */
1328 logFunction(printf("arr_remove_array\n"););
1329 isit_array(arg_1(arguments));
1330 isit_int(arg_2(arguments));
1331 isit_int(arg_3(arguments));
1332 is_variable(arg_1(arguments));
1333 arr1 = take_array(arg_1(arguments));
1334 position = take_int(arg_2(arguments));
1335 length = take_int(arg_3(arguments));
1336 if (unlikely(length < 0)) {
1337 logError(printf("arr_remove_array(arr1, " FMT_D ", " FMT_D "): "
1338 "Length is negative.\n", position, length););
1339 return raise_exception(SYS_RNG_EXCEPTION);
1340 } else if (unlikely(position < arr1->min_position ||
1341 position > arr1->max_position)) {
1342 logError(printf("arr_remove_array(arr1, " FMT_D "): "
1343 "Index out of range (" FMT_D " .. " FMT_D ").\n",
1344 position, arr1->min_position, arr1->max_position););
1345 return raise_exception(SYS_IDX_EXCEPTION);
1346 } else {
1347 arr1_size = arraySize(arr1);
1348 if ((uintType) length > MAX_ARR_LEN) {
1349 result_size = MAX_ARR_LEN;
1350 } else {
1351 result_size = (memSizeType) (uintType) (length);
1352 } /* if */
1353 if (result_size > arraySize2(position, arr1->max_position)) {
1354 result_size = arraySize2(position, arr1->max_position);
1355 } /* if */
1356 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1357 return raise_exception(SYS_MEM_EXCEPTION);
1358 } else {
1359 result->min_position = arr1->min_position;
1360 result->max_position = arrayMaxPos(arr1->min_position, result_size);
1361 array_pointer = arr1->arr;
1362 memcpy(result->arr, &array_pointer[arrayIndex(arr1, position)],
1363 result_size * sizeof(objectRecord));
1364 memmove(&array_pointer[arrayIndex(arr1, position)],
1365 &array_pointer[arrayIndex(arr1, position) + result_size],
1366 (arraySize2(position, arr1->max_position) - result_size) * sizeof(objectRecord));
1367 arr1_size = arraySize(arr1);
1368 resized_arr1 = REALLOC_ARRAY(arr1, arr1_size, arr1_size - result_size);
1369 if (unlikely(resized_arr1 == NULL)) {
1370 /* A realloc, which shrinks memory, usually succeeds. */
1371 /* The probability that this code path is executed is */
1372 /* probably zero. The code below restores the old */
1373 /* value of arr1. */
1374 memmove(&array_pointer[arrayIndex(arr1, position) + result_size],
1375 &array_pointer[arrayIndex(arr1, position)],
1376 (arraySize2(position, arr1->max_position) - result_size) * sizeof(objectRecord));
1377 memcpy(&array_pointer[arrayIndex(arr1, position)], result->arr,
1378 result_size * sizeof(objectRecord));
1379 FREE_ARRAY(result, result_size);
1380 return raise_exception(SYS_MEM_EXCEPTION);
1381 } else {
1382 arr1 = resized_arr1;
1383 COUNT3_ARRAY(arr1_size, arr1_size - result_size);
1384 arr1->max_position = arrayMaxPos(arr1->min_position, arr1_size - result_size);
1385 arg_1(arguments)->value.arrayValue = arr1;
1386 } /* if */
1387 } /* if */
1388 } /* if */
1389 return bld_array_temp(result);
1390 } /* arr_remove_array */
1391
1392
1393
arr_sort(listType arguments)1394 objectType arr_sort (listType arguments)
1395
1396 {
1397 objectType arr_arg;
1398 objectType data_cmp_func;
1399 arrayType arr1;
1400 memSizeType result_size;
1401 arrayType result;
1402
1403 /* arr_sort */
1404 arr_arg = arg_1(arguments);
1405 isit_array(arr_arg);
1406 data_cmp_func = take_reference(arg_2(arguments));
1407 if (TEMP2_OBJECT(arr_arg)) {
1408 result = take_array(arr_arg);
1409 arr_arg->value.arrayValue = NULL;
1410 } else {
1411 arr1 = take_array(arr_arg);
1412 result_size = arraySize(arr1);
1413 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1414 return raise_exception(SYS_MEM_EXCEPTION);
1415 } /* if */
1416 result->min_position = arr1->min_position;
1417 result->max_position = arr1->max_position;
1418 if (unlikely(!crea_array(result->arr, arr1->arr, result_size))) {
1419 FREE_ARRAY(result, result_size);
1420 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1421 } /* if */
1422 } /* if */
1423 qsort_array(result->arr,
1424 &result->arr[result->max_position - result->min_position],
1425 data_cmp_func);
1426 return bld_array_temp(result);
1427 } /* arr_sort */
1428
1429
1430
1431 /**
1432 * Get a sub array from the position 'start' with maximum length 'length'.
1433 * @return the sub array from position 'start' with maximum length 'length'.
1434 * @exception INDEX_ERROR The start position is less than minIdx(arr1), or
1435 * the length is negative.
1436 * @exception MEMORY_ERROR Not enough memory to represent the result.
1437 */
arr_subarr(listType arguments)1438 objectType arr_subarr (listType arguments)
1439
1440 {
1441 arrayType arr1;
1442 intType start;
1443 intType length;
1444 memSizeType arr1_size;
1445 memSizeType result_size;
1446 memSizeType start_idx;
1447 memSizeType stop_idx;
1448 arrayType result;
1449
1450 /* arr_subarr */
1451 isit_array(arg_1(arguments));
1452 isit_int(arg_3(arguments));
1453 isit_int(arg_5(arguments));
1454 arr1 = take_array(arg_1(arguments));
1455 start = take_int(arg_3(arguments));
1456 length = take_int(arg_5(arguments));
1457 if (unlikely(start < arr1->min_position || length < 0)) {
1458 return raise_exception(SYS_IDX_EXCEPTION);
1459 } /* if */
1460 arr1_size = arraySize(arr1);
1461 if (length != 0 && start <= arr1->max_position && arr1_size >= 1) {
1462 if (length - 1 > arr1->max_position - start) {
1463 length = arr1->max_position - start + 1;
1464 } /* if */
1465 result_size = (memSizeType) (uintType) (length);
1466 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1467 return raise_exception(SYS_MEM_EXCEPTION);
1468 } /* if */
1469 result->min_position = arr1->min_position;
1470 result->max_position = arrayMaxPos(arr1->min_position, result_size);
1471 start_idx = arrayIndex(arr1, start);
1472 stop_idx = arrayIndex(arr1, start + length - 1);
1473 if (TEMP_OBJECT(arg_1(arguments))) {
1474 memcpy(result->arr, &arr1->arr[start_idx],
1475 (size_t) (result_size * sizeof(objectRecord)));
1476 destr_array(arr1->arr, start_idx);
1477 destr_array(&arr1->arr[stop_idx + 1], arr1_size - stop_idx - 1);
1478 FREE_ARRAY(arr1, arr1_size);
1479 arg_1(arguments)->value.arrayValue = NULL;
1480 } else {
1481 if (unlikely(!crea_array(result->arr,
1482 &arr1->arr[start_idx], result_size))) {
1483 FREE_ARRAY(result, result_size);
1484 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1485 } /* if */
1486 } /* if */
1487 } else if (unlikely(arr1->min_position == MIN_MEM_INDEX)) {
1488 logError(printf("arr_subarr(arr1 (size=" FMT_U_MEM "), " FMT_D ", " FMT_D "): "
1489 "Cannot create empty array with minimum index.\n",
1490 arr1_size, start, length););
1491 return raise_exception(SYS_RNG_EXCEPTION);
1492 } else {
1493 if (unlikely(!ALLOC_ARRAY(result, 0))) {
1494 return raise_exception(SYS_MEM_EXCEPTION);
1495 } /* if */
1496 result->min_position = arr1->min_position;
1497 result->max_position = arr1->min_position - 1;
1498 } /* if */
1499 return bld_array_temp(result);
1500 } /* arr_subarr */
1501
1502
1503
1504 /**
1505 * Get a sub array beginning at the position 'start'.
1506 * @return the sub array beginning at the start position.
1507 * @exception INDEX_ERROR The start position is less than minIdx(arr1).
1508 * @exception MEMORY_ERROR Not enough memory to represent the result.
1509 */
arr_tail(listType arguments)1510 objectType arr_tail (listType arguments)
1511
1512 {
1513 arrayType arr1;
1514 intType start;
1515 memSizeType arr1_size;
1516 memSizeType result_size;
1517 arrayType result;
1518
1519 /* arr_tail */
1520 isit_array(arg_1(arguments));
1521 isit_int(arg_3(arguments));
1522 arr1 = take_array(arg_1(arguments));
1523 start = take_int(arg_3(arguments));
1524 arr1_size = arraySize(arr1);
1525 if (unlikely(start < arr1->min_position)) {
1526 return raise_exception(SYS_IDX_EXCEPTION);
1527 } else if (start <= arr1->max_position && arr1_size >= 1) {
1528 result_size = arraySize2(start, arr1->max_position);
1529 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1530 return raise_exception(SYS_MEM_EXCEPTION);
1531 } /* if */
1532 result->min_position = arr1->min_position;
1533 result->max_position = arrayMaxPos(arr1->min_position, result_size);
1534 if (TEMP_OBJECT(arg_1(arguments))) {
1535 memcpy(result->arr, &arr1->arr[start - arr1->min_position],
1536 (size_t) (result_size * sizeof(objectRecord)));
1537 destr_array(arr1->arr, arraySize2(arr1->min_position, start) - 1);
1538 FREE_ARRAY(arr1, arr1_size);
1539 arg_1(arguments)->value.arrayValue = NULL;
1540 /* code to avoid destr_array:
1541 arr1->max_position = start - 1; */
1542 } else {
1543 if (unlikely(!crea_array(result->arr,
1544 &arr1->arr[start - arr1->min_position], result_size))) {
1545 FREE_ARRAY(result, result_size);
1546 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1547 } /* if */
1548 } /* if */
1549 } else if (unlikely(arr1->min_position == MIN_MEM_INDEX)) {
1550 logError(printf("arr_tail(arr1 (size=" FMT_U_MEM "), " FMT_D "): "
1551 "Cannot create empty array with minimum index.\n",
1552 arr1_size, start););
1553 return raise_exception(SYS_RNG_EXCEPTION);
1554 } else {
1555 if (unlikely(!ALLOC_ARRAY(result, 0))) {
1556 return raise_exception(SYS_MEM_EXCEPTION);
1557 } /* if */
1558 result->min_position = arr1->min_position;
1559 result->max_position = arr1->min_position - 1;
1560 } /* if */
1561 return bld_array_temp(result);
1562 } /* arr_tail */
1563
1564
1565
1566 /**
1567 * Generate an array by using 'factor' 'elements'.
1568 * @return an array with 'factor' 'elements'.
1569 * @exception RANGE_ERROR If 'factor' is negative.
1570 * @exception MEMORY_ERROR Not enough memory to represent the result.
1571 */
arr_times(listType arguments)1572 objectType arr_times (listType arguments)
1573
1574 {
1575 intType factor;
1576 objectType element;
1577 memSizeType position;
1578 objectType elem_to;
1579 typeType result_element_type;
1580 memSizeType result_size;
1581 arrayType result;
1582
1583 /* arr_times */
1584 isit_int(arg_1(arguments));
1585 factor = take_int(arg_1(arguments));
1586 element = arg_3(arguments);
1587 if (unlikely(factor < 0)) {
1588 logError(printf("arr_times(" FMT_D ", ...): Factor negative.\n",
1589 factor););
1590 return raise_exception(SYS_RNG_EXCEPTION);
1591 } else if (unlikely((uintType) factor > MAX_ARR_LEN ||
1592 (uintType) factor > MAX_MEM_INDEX)) {
1593 return raise_exception(SYS_MEM_EXCEPTION);
1594 } else {
1595 result_size = (memSizeType) (uintType) factor;
1596 if (unlikely(!ALLOC_ARRAY(result, result_size))) {
1597 return raise_exception(SYS_MEM_EXCEPTION);
1598 } else {
1599 result->min_position = 1;
1600 result->max_position = factor;
1601 elem_to = result->arr;
1602 if (result_size > 0) {
1603 /* The element type of the result is the type of the 3rd formal parameter */
1604 result_element_type = curr_exec_object->value.listValue->obj->
1605 descriptor.property->params->next->next->obj->type_of;
1606 if (TEMP_OBJECT(element) && element->type_of == result_element_type) {
1607 CLEAR_TEMP_FLAG(element);
1608 SET_VAR_FLAG(element);
1609 memcpy(elem_to, element, sizeof(objectRecord));
1610 FREE_OBJECT(element);
1611 arg_3(arguments) = NULL;
1612 } else {
1613 if (unlikely(!arr_elem_initialisation(result_element_type,
1614 elem_to, element))) {
1615 FREE_ARRAY(result, result_size);
1616 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1617 } /* if */
1618 } /* if */
1619 position = 1;
1620 while (position < result_size) {
1621 if (unlikely(!arr_elem_initialisation(result_element_type,
1622 &elem_to[position], elem_to))) {
1623 /* If a create fails (mostly no memory) all elements */
1624 /* created up to this point must be destroyed to recycle */
1625 /* the memory correct. */
1626 destr_array(elem_to, position);
1627 FREE_ARRAY(result, result_size);
1628 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1629 } /* if */
1630 position++;
1631 } /* for */
1632 } /* if */
1633 return bld_array_temp(result);
1634 } /* if */
1635 } /* if */
1636 } /* arr_times */
1637