1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2008 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/rfllib.c */
23 /* Changes: 1991, 1992, 1993, 1994, 1995 Thomas Mertes */
24 /* Content: All primitive actions for the ref_list type. */
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
36 #include "common.h"
37 #include "data.h"
38 #include "heaputl.h"
39 #include "flistutl.h"
40 #include "syvarutl.h"
41 #include "traceutl.h"
42 #include "listutl.h"
43 #include "objutl.h"
44 #include "exec.h"
45 #include "runerr.h"
46
47 #undef EXTERN
48 #define EXTERN
49 #include "rfllib.h"
50
51
52
53 /**
54 * Append the ref_list 'extension/arg_3' to 'dest/arg_1'.
55 * @exception MEMORY_ERROR Not enough memory for the concatenated
56 * ref_list.
57 */
rfl_append(listType arguments)58 objectType rfl_append (listType arguments)
59
60 {
61 objectType rfl_variable;
62 listType rfl_to;
63 listType rfl_from;
64 listType list1_end;
65 listType list2_start;
66 errInfoType err_info = OKAY_NO_ERROR;
67
68 /* rfl_append */
69 rfl_variable = arg_1(arguments);
70 isit_reflist(rfl_variable);
71 is_variable(rfl_variable);
72 rfl_to = take_reflist(rfl_variable);
73 isit_reflist(arg_3(arguments));
74 rfl_from = take_reflist(arg_3(arguments));
75 if (TEMP_OBJECT(arg_3(arguments))) {
76 list2_start = rfl_from;
77 arg_3(arguments)->value.listValue = NULL;
78 } else {
79 list2_start = copy_list(rfl_from, &err_info);
80 if (err_info != OKAY_NO_ERROR) {
81 return raise_exception(SYS_MEM_EXCEPTION);
82 } /* if */
83 } /* if */
84 if (rfl_to != NULL) {
85 list1_end = rfl_to;
86 while (list1_end->next != NULL) {
87 list1_end = list1_end->next;
88 } /* while */
89 list1_end->next = list2_start;
90 } else {
91 rfl_variable->value.listValue = list2_start;
92 } /* if */
93 return SYS_EMPTY_OBJECT;
94 } /* rfl_append */
95
96
97
98 /**
99 * Concatenate two ref_lists ('list1/arg_1' and 'list2/arg_3').
100 * @return the result of the concatenation.
101 * @exception MEMORY_ERROR Not enough memory to represent the result.
102 */
rfl_cat(listType arguments)103 objectType rfl_cat (listType arguments)
104
105 {
106 objectType arg1;
107 objectType arg2;
108 listType list1_end;
109 listType list2_start;
110 errInfoType err_info = OKAY_NO_ERROR;
111 listType result;
112
113 /* rfl_cat */
114 arg1 = arg_1(arguments);
115 arg2 = arg_3(arguments);
116 isit_reflist(arg1);
117 isit_reflist(arg2);
118 if (TEMP_OBJECT(arg1)) {
119 result = take_reflist(arg1);
120 } else {
121 result = copy_list(take_reflist(arg1), &err_info);
122 if (err_info != OKAY_NO_ERROR) {
123 return raise_exception(SYS_MEM_EXCEPTION);
124 } /* if */
125 } /* if */
126 if (TEMP_OBJECT(arg2)) {
127 list2_start = take_reflist(arg2);
128 arg2->value.listValue = NULL;
129 } else {
130 list2_start = copy_list(take_reflist(arg2), &err_info);
131 if (err_info != OKAY_NO_ERROR) {
132 return raise_exception(SYS_MEM_EXCEPTION);
133 } /* if */
134 } /* if */
135 if (TEMP_OBJECT(arg1)) {
136 /* Necessary at this place: */
137 /* If an exception is raised the arguments must */
138 /* be unchanged to give a correct exception warning */
139 /* and to give a clean state to the exception handler. */
140 arg1->value.listValue = NULL;
141 } /* if */
142 if (result != NULL) {
143 list1_end = result;
144 while (list1_end->next != NULL) {
145 list1_end = list1_end->next;
146 } /* while */
147 list1_end->next = list2_start;
148 } else {
149 result = list2_start;
150 } /* if */
151 return bld_reflist_temp(result);
152 } /* rfl_cat */
153
154
155
156 /**
157 * Assign source/arg_3 to dest/arg_1.
158 * A copy function assumes that dest/arg_1 contains a legal value.
159 */
rfl_cpy(listType arguments)160 objectType rfl_cpy (listType arguments)
161
162 {
163 objectType dest;
164 objectType source;
165 listType help_list;
166 errInfoType err_info = OKAY_NO_ERROR;
167
168 /* rfl_cpy */
169 dest = arg_1(arguments);
170 source = arg_3(arguments);
171 isit_reflist(dest);
172 isit_reflist(source);
173 is_variable(dest);
174 if (source != dest) {
175 if (TEMP_OBJECT(source)) {
176 free_list(take_reflist(dest));
177 dest->value.listValue = take_reflist(source);
178 source->value.listValue = NULL;
179 } else {
180 help_list = copy_list(take_reflist(source), &err_info);
181 if (err_info != OKAY_NO_ERROR) {
182 return raise_exception(SYS_MEM_EXCEPTION);
183 } else {
184 free_list(take_reflist(dest));
185 dest->value.listValue = help_list;
186 } /* if */
187 } /* if */
188 } /* if */
189 return SYS_EMPTY_OBJECT;
190 } /* rfl_cpy */
191
192
193
194 /**
195 * Initialize dest/arg_1 and assign source/arg_3 to it.
196 * A create function assumes that the contents of dest/arg_1
197 * is undefined. Create functions can be used to initialize
198 * constants.
199 */
rfl_create(listType arguments)200 objectType rfl_create (listType arguments)
201
202 {
203 objectType dest;
204 objectType source;
205 errInfoType err_info = OKAY_NO_ERROR;
206
207 /* rfl_create */
208 dest = arg_1(arguments);
209 source = arg_3(arguments);
210 SET_CATEGORY_OF_OBJ(dest, REFLISTOBJECT);
211 isit_reflist(source);
212 if (TEMP_OBJECT(source)) {
213 dest->value.listValue = take_reflist(source);
214 source->value.listValue = NULL;
215 } else {
216 dest->value.listValue = copy_list(take_reflist(source), &err_info);
217 if (err_info != OKAY_NO_ERROR) {
218 dest->value.listValue = NULL;
219 return raise_exception(SYS_MEM_EXCEPTION);
220 } /* if */
221 } /* if */
222 return SYS_EMPTY_OBJECT;
223 } /* rfl_create */
224
225
226
227 /**
228 * Free the memory referred by 'old_list/arg_1'.
229 * After rfl_destr is left 'old_list/arg_1' is NULL.
230 * The memory where 'old_list/arg_1' is stored can be freed afterwards.
231 */
rfl_destr(listType arguments)232 objectType rfl_destr (listType arguments)
233
234 { /* rfl_destr */
235 isit_reflist(arg_1(arguments));
236 free_list(take_reflist(arg_1(arguments)));
237 arg_1(arguments)->value.listValue = NULL;
238 SET_UNUSED_FLAG(arg_1(arguments));
239 return SYS_EMPTY_OBJECT;
240 } /* rfl_destr */
241
242
243
rfl_elem(listType arguments)244 objectType rfl_elem (listType arguments)
245
246 {
247 objectType searched_object;
248 listType list_element;
249
250 /* rfl_elem */
251 isit_reference(arg_1(arguments));
252 isit_reflist(arg_3(arguments));
253 searched_object = take_reference(arg_1(arguments));
254 list_element = take_reflist(arg_3(arguments));
255 while (list_element != NULL && list_element->obj != searched_object) {
256 list_element = list_element->next;
257 } /* while */
258 if (list_element != NULL) {
259 return SYS_TRUE_OBJECT;
260 } else {
261 return SYS_FALSE_OBJECT;
262 } /* if */
263 } /* rfl_elem */
264
265
266
267 /**
268 * Assign reference 'source/arg_6' to the 'position/arg_4' of the 'dest/arg_1'.
269 * A @:= [B] C;
270 * is equivalent to
271 * A := A[..pred(B)] & make_list(C) & A[succ(B)..];
272 * @exception INDEX_ERROR If 'position/arg_4' is negative or zero, or
273 * an element beyond 'dest/arg_1' would be overwritten
274 * ('position/arg_4' > length('dest/arg_1') holds).
275 */
rfl_elemcpy(listType arguments)276 objectType rfl_elemcpy (listType arguments)
277
278 {
279 intType position;
280 listType list_element;
281
282 /* rfl_elemcpy */
283 isit_reflist(arg_1(arguments));
284 isit_int(arg_4(arguments));
285 isit_reference(arg_6(arguments));
286 is_variable(arg_1(arguments));
287 list_element = take_reflist(arg_1(arguments));
288 position = take_int(arg_4(arguments));
289 if (unlikely(position <= 0)) {
290 logError(printf("rfl_elemcpy(" FMT_U_MEM ", " FMT_D ", " FMT_U_MEM "): "
291 "Index <= 0.\n",
292 (memSizeType) take_reflist(arg_1(arguments)),
293 position,
294 (memSizeType) take_reference(arg_6(arguments))););
295 return raise_exception(SYS_IDX_EXCEPTION);
296 } else {
297 position--;
298 while (position != 0 && list_element != NULL) {
299 position--;
300 list_element = list_element->next;
301 } /* while */
302 if (unlikely(list_element == NULL)) {
303 logError(printf("rfl_elemcpy(" FMT_U_MEM ", " FMT_D ", " FMT_U_MEM "): "
304 "Index > length(dest).\n",
305 (memSizeType) take_reflist(arg_1(arguments)),
306 position,
307 (memSizeType) take_reference(arg_6(arguments))););
308 return raise_exception(SYS_IDX_EXCEPTION);
309 } else {
310 list_element->obj = take_reference(arg_6(arguments));
311 } /* if */
312 } /* if */
313 return SYS_EMPTY_OBJECT;
314 } /* rfl_elemcpy */
315
316
317
rfl_empty(listType arguments)318 objectType rfl_empty (listType arguments)
319
320 { /* rfl_empty */
321 return bld_reflist_temp(NULL);
322 } /* rfl_empty */
323
324
325
326 /**
327 * Check if two ref_lists are equal.
328 * @return TRUE if both ref_lists are equal,
329 * FALSE otherwise.
330 */
rfl_eq(listType arguments)331 objectType rfl_eq (listType arguments)
332
333 {
334 listType list1;
335 listType list2;
336 objectType result;
337
338 /* rfl_eq */
339 isit_reflist(arg_1(arguments));
340 isit_reflist(arg_3(arguments));
341 list1 = take_reflist(arg_1(arguments));
342 list2 = take_reflist(arg_3(arguments));
343 while (list1 != NULL && list2 != NULL &&
344 list1->obj == list2->obj) {
345 list1 = list1->next;
346 list2 = list2->next;
347 } /* while */
348 if (list1 == NULL && list2 == NULL) {
349 result = SYS_TRUE_OBJECT;
350 } else {
351 result = SYS_FALSE_OBJECT;
352 } /* if */
353 return result;
354 } /* rfl_eq */
355
356
357
rfl_excl(listType arguments)358 objectType rfl_excl (listType arguments)
359
360 { /* rfl_excl */
361 isit_reflist(arg_1(arguments));
362 isit_reference(arg_2(arguments));
363 excl_list(&arg_1(arguments)->value.listValue,
364 take_reference(arg_2(arguments)));
365 return SYS_EMPTY_OBJECT;
366 } /* rfl_excl */
367
368
369
rfl_expr(listType arguments)370 objectType rfl_expr (listType arguments)
371
372 {
373 listType list1;
374 objectType arg1_object;
375 objectType arg3_object;
376 boolType okay;
377 errInfoType err_info = OKAY_NO_ERROR;
378 listType result;
379
380 /* rfl_expr */
381 isit_list(arg_1(arguments));
382 list1 = take_list(arg_1(arguments));
383 logFunction(printf("rfl_expr(");
384 prot_list(list1);
385 printf(")\n"););
386 result = NULL;
387 if (list1 != NULL &&
388 list1->next == NULL) {
389 arg1_object = arg_1(list1);
390 incl_list(&result, arg1_object, &err_info);
391 } else {
392 okay = TRUE;
393 do {
394 if (list1 != NULL &&
395 list1->next != NULL &&
396 list1->next->next != NULL &&
397 list1->next->next->next == NULL) {
398 arg1_object = arg_1(list1);
399 arg3_object = arg_3(list1);
400 incl_list(&result, arg3_object, &err_info);
401 if (CATEGORY_OF_OBJ(arg1_object) == EXPROBJECT) {
402 list1 = take_list(arg1_object);
403 } else {
404 incl_list(&result, arg1_object, &err_info);
405 okay = FALSE;
406 } /* if */
407 } else {
408 logError(printf("rfl_expr: Not okay\n");
409 printf("list1: " FMT_X_MEM "\n", (memSizeType) list1);
410 printf("list1->next: " FMT_X_MEM "\n",
411 (memSizeType) list1->next);
412 printf("list1->next->next: " FMT_X_MEM "\n",
413 (memSizeType) list1->next->next);
414 printf("list1->next->next->next: " FMT_X_MEM "\n",
415 (memSizeType) list1->next->next->next););
416 return raise_exception(SYS_RNG_EXCEPTION);
417 } /* if */
418 } while (okay);
419 } /* if */
420 logFunction(printf("rfl_expr --> ");
421 prot_list(result);
422 printf("\n"););
423 return bld_reflist_temp(result);
424 } /* rfl_expr */
425
426
427
rfl_for(listType arguments)428 objectType rfl_for (listType arguments)
429
430 {
431 objectType statement;
432 objectType elementlist;
433 objectType for_variable;
434 listType helplist;
435 listType listelement;
436 errInfoType err_info = OKAY_NO_ERROR;
437 objectType result;
438
439 /* rfl_for */
440 /* prot_list(take_list(arg_4(arguments))); */
441 for_variable = arg_2(arguments);
442 elementlist = arg_4(arguments);
443 statement = arg_6(arguments);
444 isit_reference (for_variable);
445 isit_reflist(elementlist);
446 helplist = copy_list(take_list(elementlist), &err_info);
447 if (err_info != OKAY_NO_ERROR) {
448 return raise_exception(SYS_MEM_EXCEPTION);
449 } else {
450 listelement = helplist;
451 result = SYS_EMPTY_OBJECT;
452 while (listelement != NULL && result != NULL) {
453 for_variable->value.objValue = listelement->obj;
454 result = evaluate(statement);
455 listelement = listelement->next;
456 } /* while */
457 free_list(helplist);
458 return result;
459 } /* if */
460 } /* rfl_for */
461
462
463
rfl_for_until(listType arguments)464 objectType rfl_for_until (listType arguments)
465
466 {
467 objectType for_variable;
468 objectType elementlist;
469 objectType statement;
470 objectType condition;
471 objectType cond_value;
472 boolType cond;
473 listType helplist;
474 listType listelement;
475 errInfoType err_info = OKAY_NO_ERROR;
476
477 /* rfl_for_until */
478 /* prot_list(take_list(arg_4(arguments))); */
479 for_variable = arg_2(arguments);
480 elementlist = arg_4(arguments);
481 condition = arg_6(arguments);
482 statement = arg_8(arguments);
483 isit_reference (for_variable);
484 isit_reflist(elementlist);
485 helplist = copy_list(take_list(elementlist), &err_info);
486 if (err_info != OKAY_NO_ERROR) {
487 return raise_exception(SYS_MEM_EXCEPTION);
488 } else {
489 listelement = helplist;
490 if (listelement != NULL) {
491 for_variable->value.objValue = listelement->obj;
492 cond_value = evaluate(condition);
493 if (!fail_flag) {
494 isit_bool(cond_value);
495 cond = (boolType) (take_bool(cond_value) == SYS_FALSE_OBJECT);
496 if (TEMP_OBJECT(cond_value)) {
497 dump_any_temp(cond_value);
498 } /* if */
499 while (cond && listelement != NULL && !fail_flag) {
500 evaluate(statement);
501 if (!fail_flag) {
502 listelement = listelement->next;
503 if (listelement != NULL) {
504 for_variable->value.objValue = listelement->obj;
505 cond_value = evaluate(condition);
506 if (!fail_flag) {
507 isit_bool(cond_value);
508 cond = (boolType) (take_bool(cond_value) == SYS_FALSE_OBJECT);
509 if (TEMP_OBJECT(cond_value)) {
510 dump_any_temp(cond_value);
511 } /* if */
512 } /* if */
513 } /* if */
514 } /* if */
515 } /* while */
516 } /* if */
517 } /* if */
518 free_list(helplist);
519 return SYS_EMPTY_OBJECT;
520 } /* if */
521 } /* rfl_for_until */
522
523
524
525 /**
526 * Get a sublist from 'list/arg_1' ending at the 'stop/arg_4' position.
527 * The first element in a 'ref_list' has the position 1.
528 * @return the substring ending at the 'stop/arg_4' position.
529 * @exception MEMORY_ERROR Not enough memory to represent the result.
530 */
rfl_head(listType arguments)531 objectType rfl_head (listType arguments)
532
533 {
534 objectType list;
535 intType stop;
536 intType number;
537 listType stop_element;
538 listType saved_list_rest;
539 errInfoType err_info = OKAY_NO_ERROR;
540 listType result;
541
542 /* rfl_head */
543 isit_int(arg_4(arguments));
544 list = arg_1(arguments);
545 isit_reflist(list);
546 stop = take_int(arg_4(arguments));
547 if (stop >= 1) {
548 number = 1;
549 stop_element = take_reflist(list);
550 while (number < stop && stop_element != NULL) {
551 number++;
552 stop_element = stop_element->next;
553 } /* while */
554 if (TEMP_OBJECT(list)) {
555 if (stop_element != NULL) {
556 free_list(stop_element->next);
557 stop_element->next = NULL;
558 } /* if */
559 result = take_reflist(list);
560 list->value.listValue = NULL;
561 } else {
562 if (stop_element != NULL) {
563 saved_list_rest = stop_element->next;
564 stop_element->next = NULL;
565 result = copy_list(take_reflist(list), &err_info);
566 stop_element->next = saved_list_rest;
567 } else {
568 result = copy_list(take_reflist(list), &err_info);
569 } /* if */
570 } /* if */
571 } else {
572 result = NULL;
573 } /* if */
574 if (err_info != OKAY_NO_ERROR) {
575 return raise_exception(SYS_MEM_EXCEPTION);
576 } else {
577 return bld_reflist_temp(result);
578 } /* if */
579 } /* rfl_head */
580
581
582
583 /**
584 * Access one element from the 'ref_list' 'list/arg_1'.
585 * @return the element with the specified 'position/arg_3' from 'list/arg_1'.
586 * @exception INDEX_ERROR If the index is less than 1 or
587 * greater than the length of the 'ref_list'.
588 */
rfl_idx(listType arguments)589 objectType rfl_idx (listType arguments)
590
591 {
592 intType position;
593 listType list_element;
594 objectType result;
595
596 /* rfl_idx */
597 isit_reflist(arg_1(arguments));
598 isit_int(arg_3(arguments));
599 list_element = take_reflist(arg_1(arguments));
600 position = take_int(arg_3(arguments));
601 if (unlikely(position <= 0)) {
602 logError(printf("rfl_idx(" FMT_U_MEM ", " FMT_D "): "
603 "Index <= 0.\n",
604 (memSizeType) take_reflist(arg_1(arguments)),
605 position););
606 result = raise_exception(SYS_IDX_EXCEPTION);
607 } else {
608 position--;
609 while (position != 0 && list_element != NULL) {
610 position--;
611 list_element = list_element->next;
612 } /* while */
613 if (unlikely(list_element == NULL)) {
614 logError(printf("rfl_idx(" FMT_U_MEM ", " FMT_D "): "
615 "Index > length(list).\n",
616 (memSizeType) take_reflist(arg_1(arguments)),
617 position););
618 result = raise_exception(SYS_IDX_EXCEPTION);
619 } else {
620 result = bld_reference_temp(list_element->obj);
621 } /* if */
622 } /* if */
623 return result;
624 } /* rfl_idx */
625
626
627
rfl_incl(listType arguments)628 objectType rfl_incl (listType arguments)
629
630 {
631 errInfoType err_info = OKAY_NO_ERROR;
632
633 /* rfl_incl */
634 isit_reflist(arg_1(arguments));
635 isit_reference(arg_2(arguments));
636 incl_list(&arg_1(arguments)->value.listValue,
637 take_reference(arg_2(arguments)), &err_info);
638 if (err_info != OKAY_NO_ERROR) {
639 return raise_exception(SYS_MEM_EXCEPTION);
640 } else {
641 return SYS_EMPTY_OBJECT;
642 } /* if */
643 } /* rfl_incl */
644
645
646
rfl_ipos(listType arguments)647 objectType rfl_ipos (listType arguments)
648
649 {
650 listType list_element;
651 objectType searched_object;
652 intType from_index;
653 intType result;
654
655 /* rfl_ipos */
656 isit_reflist(arg_1(arguments));
657 isit_reference(arg_2(arguments));
658 list_element = take_reflist(arg_1(arguments));
659 searched_object = take_reference(arg_2(arguments));
660 from_index = take_int(arg_3(arguments));
661 result = 1;
662 while (list_element != NULL && result < from_index) {
663 list_element = list_element->next;
664 result++;
665 } /* while */
666 while (list_element != NULL && list_element->obj != searched_object) {
667 list_element = list_element->next;
668 result++;
669 } /* while */
670 if (list_element == NULL) {
671 result = 0;
672 } /* if */
673 return bld_int_temp(result);
674 } /* rfl_ipos */
675
676
677
678 /**
679 * Determine the length of a 'ref_list'.
680 * @return the length of the 'ref_list'.
681 */
rfl_lng(listType arguments)682 objectType rfl_lng (listType arguments)
683
684 {
685 listType list_element;
686 intType length = 0;
687
688 /* rfl_lng */
689 isit_reflist(arg_1(arguments));
690 list_element = take_reflist(arg_1(arguments));
691 while (list_element != NULL) {
692 list_element = list_element->next;
693 length++;
694 } /* while */
695 return bld_int_temp(length);
696 } /* rfl_lng */
697
698
699
rfl_mklist(listType arguments)700 objectType rfl_mklist (listType arguments)
701
702 {
703 listType result;
704
705 /* rfl_mklist */
706 isit_reference(arg_1(arguments));
707 if (ALLOC_L_ELEM(result)) {
708 result->next = NULL;
709 result->obj = take_reference(arg_1(arguments));
710 return bld_reflist_temp(result);
711 } else {
712 return raise_exception(SYS_MEM_EXCEPTION);
713 } /* if */
714 } /* rfl_mklist */
715
716
717
718 /**
719 * Check if two ref_lists are not equal.
720 * @return FALSE if both ref_lists are equal,
721 * TRUE otherwise.
722 */
rfl_ne(listType arguments)723 objectType rfl_ne (listType arguments)
724
725 {
726 listType list1;
727 listType list2;
728 objectType result;
729
730 /* rfl_ne */
731 isit_reflist(arg_1(arguments));
732 isit_reflist(arg_3(arguments));
733 list1 = take_reflist(arg_1(arguments));
734 list2 = take_reflist(arg_3(arguments));
735 while (list1 != NULL && list2 != NULL &&
736 list1->obj == list2->obj) {
737 list1 = list1->next;
738 list2 = list2->next;
739 } /* while */
740 if (list1 != NULL || list2 != NULL) {
741 result = SYS_TRUE_OBJECT;
742 } else {
743 result = SYS_FALSE_OBJECT;
744 } /* if */
745 return result;
746 } /* rfl_ne */
747
748
749
rfl_not_elem(listType arguments)750 objectType rfl_not_elem (listType arguments)
751
752 {
753 objectType searched_object;
754 listType list_element;
755
756 /* rfl_not_elem */
757 isit_reference(arg_1(arguments));
758 isit_reflist(arg_4(arguments));
759 searched_object = take_reference(arg_1(arguments));
760 list_element = take_reflist(arg_4(arguments));
761 while (list_element != NULL && list_element->obj != searched_object) {
762 list_element = list_element->next;
763 } /* while */
764 if (list_element == NULL) {
765 return SYS_TRUE_OBJECT;
766 } else {
767 return SYS_FALSE_OBJECT;
768 } /* if */
769 } /* rfl_not_elem */
770
771
772
rfl_pos(listType arguments)773 objectType rfl_pos (listType arguments)
774
775 {
776 listType list_element;
777 objectType searched_object;
778 intType result;
779
780 /* rfl_pos */
781 isit_reflist(arg_1(arguments));
782 isit_reference(arg_2(arguments));
783 list_element = take_reflist(arg_1(arguments));
784 searched_object = take_reference(arg_2(arguments));
785 result = 1;
786 while (list_element != NULL && list_element->obj != searched_object) {
787 list_element = list_element->next;
788 result++;
789 } /* while */
790 if (list_element == NULL) {
791 result = 0;
792 } /* if */
793 return bld_int_temp(result);
794 } /* rfl_pos */
795
796
797
798 /**
799 * Get a sublist from a 'start/arg_3' position to a 'stop/arg_5' position.
800 * The first element in a 'ref_list' has the position 1.
801 * @return the substring from position start to stop.
802 * @exception MEMORY_ERROR Not enough memory to represent the result.
803 */
rfl_range(listType arguments)804 objectType rfl_range (listType arguments)
805
806 {
807 objectType list;
808 intType start;
809 intType stop;
810 intType number;
811 listType start_element;
812 listType stop_element;
813 listType *start_address;
814 listType saved_list_rest;
815 errInfoType err_info = OKAY_NO_ERROR;
816 listType result;
817
818 /* rfl_range */
819 isit_reflist(arg_1(arguments));
820 isit_int(arg_3(arguments));
821 isit_int(arg_5(arguments));
822 list = arg_1(arguments);
823 start = take_int(arg_3(arguments));
824 stop = take_int(arg_5(arguments));
825 number = 1;
826 start_address = &take_reflist(list);
827 start_element = take_reflist(list);
828 while (number < start && start_element != NULL) {
829 number++;
830 start_address = &start_element->next;
831 start_element = start_element->next;
832 } /* while */
833 if (start_element != NULL && stop >= start) {
834 stop_element = start_element;
835 while (number < stop && stop_element != NULL) {
836 number++;
837 stop_element = stop_element->next;
838 } /* while */
839 if (TEMP_OBJECT(list)) {
840 *start_address = stop_element;
841 result = start_element;
842 } else {
843 if (stop_element != NULL) {
844 saved_list_rest = stop_element->next;
845 stop_element->next = NULL;
846 result = copy_list(start_element, &err_info);
847 stop_element->next = saved_list_rest;
848 } else {
849 result = copy_list(start_element, &err_info);
850 } /* if */
851 } /* if */
852 } else {
853 result = NULL;
854 } /* if */
855 if (err_info != OKAY_NO_ERROR) {
856 return raise_exception(SYS_MEM_EXCEPTION);
857 } else {
858 return bld_reflist_temp(result);
859 } /* if */
860 } /* rfl_range */
861
862
863
rfl_set_value(listType arguments)864 objectType rfl_set_value (listType arguments)
865
866 {
867 objectType list_to;
868 objectType list_from;
869 listType help_list;
870 errInfoType err_info = OKAY_NO_ERROR;
871
872 /* rfl_set_value */
873 isit_reference(arg_1(arguments));
874 is_variable(arg_1(arguments));
875 list_to = take_reference(arg_1(arguments));
876 list_from = arg_2(arguments);
877 isit_reflist(list_from);
878 if (CATEGORY_OF_OBJ(list_to) == MATCHOBJECT ||
879 CATEGORY_OF_OBJ(list_to) == CALLOBJECT ||
880 CATEGORY_OF_OBJ(list_to) == REFLISTOBJECT) {
881 if (list_from != list_to) {
882 if (TEMP_OBJECT(list_from)) {
883 free_list(take_reflist(list_to));
884 list_to->value.listValue = take_reflist(list_from);
885 list_from->value.listValue = NULL;
886 } else {
887 help_list = copy_list(take_reflist(list_from), &err_info);
888 if (err_info != OKAY_NO_ERROR) {
889 return raise_exception(SYS_MEM_EXCEPTION);
890 } else {
891 free_list(take_reflist(list_to));
892 list_to->value.listValue = help_list;
893 } /* if */
894 } /* if */
895 } /* if */
896 } else {
897 run_error(REFLISTOBJECT, list_to);
898 } /* if */
899 return SYS_EMPTY_OBJECT;
900 } /* rfl_set_value */
901
902
903
904 /**
905 * Get a sublist from 'list/arg_1' beginning at a 'start/arg_3' position.
906 * The first element in a 'ref_list' has the position 1.
907 * @return the sublist beginning at the 'start/arg_3' position.
908 * @exception MEMORY_ERROR Not enough memory to represent the result.
909 */
rfl_tail(listType arguments)910 objectType rfl_tail (listType arguments)
911
912 {
913 objectType list;
914 intType start;
915 intType number;
916 listType list_element;
917 errInfoType err_info = OKAY_NO_ERROR;
918 listType result;
919
920 /* rfl_tail */
921 isit_reflist(arg_1(arguments));
922 isit_int(arg_3(arguments));
923 list = arg_1(arguments);
924 start = take_int(arg_3(arguments));
925 list_element = take_reflist(list);
926 if (start > 1 && list_element != NULL) {
927 number = 2;
928 while (number < start && list_element->next != NULL) {
929 number++;
930 list_element = list_element->next;
931 } /* while */
932 if (number >= start) {
933 if (TEMP_OBJECT(list)) {
934 result = list_element->next;
935 list_element->next = NULL;
936 } else {
937 result = copy_list(list_element->next, &err_info);
938 } /* if */
939 } else {
940 result = NULL;
941 } /* if */
942 } else {
943 if (TEMP_OBJECT(list)) {
944 result = list_element;
945 list->value.listValue = NULL;
946 } else {
947 result = copy_list(list_element, &err_info);
948 } /* if */
949 } /* if */
950 if (err_info != OKAY_NO_ERROR) {
951 return raise_exception(SYS_MEM_EXCEPTION);
952 } else {
953 return bld_reflist_temp(result);
954 } /* if */
955 } /* rfl_tail */
956
957
958
rfl_trace(listType arguments)959 objectType rfl_trace (listType arguments)
960
961 { /* rfl_trace */
962 isit_reflist(arg_1(arguments));
963 prot_list(take_reflist(arg_1(arguments)));
964 return SYS_EMPTY_OBJECT;
965 } /* rfl_trace */
966
967
968
rfl_value(listType arguments)969 objectType rfl_value (listType arguments)
970
971 {
972 objectType obj_arg;
973 errInfoType err_info = OKAY_NO_ERROR;
974 listType result;
975
976 /* rfl_value */
977 isit_reference(arg_1(arguments));
978 obj_arg = take_reference(arg_1(arguments));
979 if (unlikely(obj_arg == NULL ||
980 (CATEGORY_OF_OBJ(obj_arg) != MATCHOBJECT &&
981 CATEGORY_OF_OBJ(obj_arg) != CALLOBJECT &&
982 CATEGORY_OF_OBJ(obj_arg) != REFLISTOBJECT))) {
983 logError(printf("rfl_value(");
984 trace1(obj_arg);
985 printf("): Category is not MATCH-, CALL- or REFLISTOBJECT.\n"););
986 return raise_exception(SYS_RNG_EXCEPTION);
987 } else {
988 result = copy_list(take_reflist(obj_arg), &err_info);
989 if (err_info != OKAY_NO_ERROR) {
990 return raise_exception(SYS_MEM_EXCEPTION);
991 } /* if */
992 } /* if */
993 return bld_reflist_temp(result);
994 } /* rfl_value */
995