1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2000 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/lstlib.c */
23 /* Changes: 1990, 1991, 1992, 1993, 1994 Thomas Mertes */
24 /* Content: All primitive actions for the 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 "listutl.h"
42 #include "executl.h"
43 #include "objutl.h"
44 #include "runerr.h"
45
46 #undef EXTERN
47 #define EXTERN
48 #include "lstlib.h"
49
50
51
lst_cat(listType arguments)52 objectType lst_cat (listType arguments)
53
54 {
55 objectType arg1;
56 objectType arg2;
57 listType list1_end;
58 listType list2_start;
59 errInfoType err_info = OKAY_NO_ERROR;
60 listType result;
61
62
63 /* lst_cat */
64 arg1 = arg_1(arguments);
65 arg2 = arg_3(arguments);
66 isit_list(arg1);
67 isit_list(arg2);
68 if (TEMP_OBJECT(arg1)) {
69 result = take_list(arg1);
70 } else {
71 result = copy_list(take_list(arg1), &err_info);
72 if (err_info != OKAY_NO_ERROR) {
73 return raise_exception(SYS_MEM_EXCEPTION);
74 } /* if */
75 } /* if */
76 if (TEMP_OBJECT(arg2)) {
77 list2_start = take_list(arg2);
78 arg2->value.listValue = NULL;
79 } else {
80 list2_start = copy_list(take_list(arg2), &err_info);
81 if (err_info != OKAY_NO_ERROR) {
82 return raise_exception(SYS_MEM_EXCEPTION);
83 } /* if */
84 } /* if */
85 if (TEMP_OBJECT(arg1)) {
86 /* Necessary at this place: */
87 /* If an exception is raised the arguments must */
88 /* be unchanged to give a correct exception warning */
89 /* and to give a clean state to the exception handler. */
90 arg1->value.listValue = NULL;
91 } /* if */
92 if (result != NULL) {
93 list1_end = result;
94 while (list1_end->next != NULL) {
95 list1_end = list1_end->next;
96 } /* while */
97 list1_end->next = list2_start;
98 } else {
99 result = list2_start;
100 } /* if */
101 return bld_list_temp(result);
102 } /* lst_cat */
103
104
105
106 /**
107 * Assign source/arg_3 to dest/arg_1.
108 * A copy function assumes that dest/arg_1 contains a legal value.
109 */
lst_cpy(listType arguments)110 objectType lst_cpy (listType arguments)
111
112 {
113 objectType dest;
114 objectType source;
115 listType help_list;
116 errInfoType err_info = OKAY_NO_ERROR;
117
118 /* lst_cpy */
119 dest = arg_1(arguments);
120 source = arg_3(arguments);
121 isit_list(dest);
122 isit_list(source);
123 is_variable(dest);
124 if (source != dest) {
125 if (TEMP_OBJECT(source)) {
126 free_list(take_list(dest));
127 dest->value.listValue = take_list(source);
128 source->value.listValue = NULL;
129 } else {
130 help_list = copy_list(take_list(source), &err_info);
131 if (err_info != OKAY_NO_ERROR) {
132 return raise_exception(SYS_MEM_EXCEPTION);
133 } else {
134 free_list(take_list(dest));
135 dest->value.listValue = help_list;
136 } /* if */
137 } /* if */
138 } /* if */
139 return SYS_EMPTY_OBJECT;
140 } /* lst_cpy */
141
142
143
144 /**
145 * Initialize dest/arg_1 and assign source/arg_3 to it.
146 * A create function assumes that the contents of dest/arg_1
147 * is undefined. Create functions can be used to initialize
148 * constants.
149 */
lst_create(listType arguments)150 objectType lst_create (listType arguments)
151
152 {
153 objectType dest;
154 objectType source;
155 errInfoType err_info = OKAY_NO_ERROR;
156
157 /* lst_create */
158 dest = arg_1(arguments);
159 source = arg_3(arguments);
160 SET_CATEGORY_OF_OBJ(dest, LISTOBJECT);
161 isit_list(source);
162 if (TEMP_OBJECT(source)) {
163 dest->value.listValue = take_list(source);
164 source->value.listValue = NULL;
165 } else {
166 dest->value.listValue = copy_list(take_list(source), &err_info);
167 if (err_info != OKAY_NO_ERROR) {
168 dest->value.listValue = NULL;
169 return raise_exception(SYS_MEM_EXCEPTION);
170 } /* if */
171 } /* if */
172 return SYS_EMPTY_OBJECT;
173 } /* lst_create */
174
175
176
lst_destr(listType arguments)177 objectType lst_destr (listType arguments)
178
179 {
180 objectType old_list;
181 register listType list_end;
182 errInfoType err_info = OKAY_NO_ERROR;
183
184 /* lst_destr */
185 old_list = arg_1(arguments);
186 isit_list(old_list);
187 list_end = take_list(old_list);
188 if (list_end != NULL) {
189 while (list_end->next != NULL) {
190 if (TEMP_OBJECT(list_end->obj)) {
191 do_destroy(list_end->obj, &err_info);
192 FREE_OBJECT(list_end->obj);
193 } /* if */
194 list_end = list_end->next;
195 } /* while */
196 if (TEMP_OBJECT(list_end->obj)) {
197 do_destroy(list_end->obj, &err_info);
198 FREE_OBJECT(list_end->obj);
199 } /* if */
200 list_end->next = flist.list_elems;
201 flist.list_elems = take_list(old_list);
202 } /* if */
203 old_list->value.listValue = NULL;
204 SET_UNUSED_FLAG(arg_1(arguments));
205 return SYS_EMPTY_OBJECT;
206 } /* lst_destr */
207
208
209
lst_elem(listType arguments)210 objectType lst_elem (listType arguments)
211
212 {
213 #ifdef OUT_OF_ORDER
214 objectType searched_object;
215 listType list_element;
216 #endif
217
218 /* lst_elem */
219 #ifdef OUT_OF_ORDER
220 isit_list(arg_3(arguments));
221 searched_object = arg_1(arguments);
222 if (CATEGORY_OF_OBJ(searched_object) == VARENUMOBJECT ||
223 CATEGORY_OF_OBJ(searched_object) == CONSTENUMOBJECT) {
224 searched_object = take_reference(searched_object);
225 } /* if */
226 list_element = take_list(arg_3(arguments));
227 while (list_element != NULL && list_element->obj != searched_object) {
228 list_element = list_element->next;
229 } /* while */
230 if (list_element != NULL) {
231 return SYS_TRUE_OBJECT;
232 } else {
233 return SYS_FALSE_OBJECT;
234 } /* if */
235 #endif
236 return raise_exception(SYS_ACT_ILLEGAL_EXCEPTION);
237 } /* lst_elem */
238
239
240
lst_empty(listType arguments)241 objectType lst_empty (listType arguments)
242
243 { /* lst_empty */
244 return bld_list_temp(NULL);
245 } /* lst_empty */
246
247
248
lst_excl(listType arguments)249 objectType lst_excl (listType arguments)
250
251 { /* lst_excl */
252 isit_list(arg_1(arguments));
253 excl_list(&arg_1(arguments)->value.listValue,
254 arg_2(arguments));
255 return SYS_EMPTY_OBJECT;
256 } /* lst_excl */
257
258
259
lst_head(listType arguments)260 objectType lst_head (listType arguments)
261
262 {
263 objectType list;
264 intType stop;
265 intType number;
266 listType stop_element;
267 listType saved_list_rest;
268 errInfoType err_info = OKAY_NO_ERROR;
269 listType result;
270
271 /* lst_head */
272 isit_int(arg_4(arguments));
273 list = arg_1(arguments);
274 isit_list(list);
275 stop = take_int(arg_4(arguments));
276 if (stop >= 1) {
277 number = 1;
278 stop_element = take_list(list);
279 while (number < stop && stop_element != NULL) {
280 number++;
281 stop_element = stop_element->next;
282 } /* while */
283 if (TEMP_OBJECT(list)) {
284 if (stop_element != NULL) {
285 free_list(stop_element->next);
286 stop_element->next = NULL;
287 } /* if */
288 result = take_list(list);
289 list->value.listValue = NULL;
290 } else {
291 if (stop_element != NULL) {
292 saved_list_rest = stop_element->next;
293 stop_element->next = NULL;
294 result = copy_list(take_list(list), &err_info);
295 stop_element->next = saved_list_rest;
296 } else {
297 result = copy_list(take_list(list), &err_info);
298 } /* if */
299 } /* if */
300 } else {
301 result = NULL;
302 } /* if */
303 if (err_info != OKAY_NO_ERROR) {
304 return raise_exception(SYS_MEM_EXCEPTION);
305 } else {
306 return bld_list_temp(result);
307 } /* if */
308 } /* lst_head */
309
310
311
lst_idx(listType arguments)312 objectType lst_idx (listType arguments)
313
314 {
315 intType position;
316 intType number;
317 listType list_element;
318 objectType result;
319
320 /* lst_idx */
321 isit_list(arg_1(arguments));
322 isit_int(arg_3(arguments));
323 list_element = take_list(arg_1(arguments));
324 position = take_int(arg_3(arguments));
325 if (position >= 1) {
326 number = 1;
327 while (number < position && list_element != NULL) {
328 number++;
329 list_element = list_element->next;
330 } /* while */
331 if (list_element != NULL) {
332 result = list_element->obj;
333 } else {
334 logError(printf("lst_idx(list1, " FMT_D "): "
335 "Index larger than maximum (" FMT_D ").\n",
336 position, number - 1););
337 result = raise_exception(SYS_RNG_EXCEPTION);
338 } /* if */
339 } else {
340 logError(printf("lst_idx(list1, " FMT_D "): "
341 "Index is negative or zero.\n", position););
342 result = raise_exception(SYS_RNG_EXCEPTION);
343 } /* if */
344 return result;
345 } /* lst_idx */
346
347
348
lst_incl(listType arguments)349 objectType lst_incl (listType arguments)
350
351 {
352 objectType obj_arg;
353 errInfoType err_info = OKAY_NO_ERROR;
354
355 /* lst_incl */
356 isit_list(arg_1(arguments));
357 obj_arg = arg_2(arguments);
358 if (CATEGORY_OF_OBJ(obj_arg) == VARENUMOBJECT ||
359 CATEGORY_OF_OBJ(obj_arg) == CONSTENUMOBJECT) {
360 obj_arg = take_reference(obj_arg);
361 } /* if */
362 incl_list(&arg_1(arguments)->value.listValue, obj_arg, &err_info);
363 if (err_info != OKAY_NO_ERROR) {
364 return raise_exception(SYS_MEM_EXCEPTION);
365 } else {
366 return SYS_EMPTY_OBJECT;
367 } /* if */
368 } /* lst_incl */
369
370
371
lst_lng(listType arguments)372 objectType lst_lng (listType arguments)
373
374 {
375 listType list_element;
376 intType length;
377
378 /* lst_lng */
379 isit_list(arg_1(arguments));
380 list_element = take_list(arg_1(arguments));
381 length = 0;
382 while (list_element != NULL) {
383 list_element = list_element->next;
384 length++;
385 } /* while */
386 return bld_int_temp(length);
387 } /* lst_lng */
388
389
390
lst_range(listType arguments)391 objectType lst_range (listType arguments)
392
393 {
394 objectType list;
395 intType start;
396 intType stop;
397 intType number;
398 listType start_element;
399 listType stop_element;
400 listType *start_address;
401 listType saved_list_rest;
402 errInfoType err_info = OKAY_NO_ERROR;
403 listType result;
404
405 /* lst_range */
406 isit_list(arg_1(arguments));
407 isit_int(arg_3(arguments));
408 isit_int(arg_5(arguments));
409 list = arg_1(arguments);
410 start = take_int(arg_3(arguments));
411 stop = take_int(arg_5(arguments));
412 number = 1;
413 start_address = &take_list(list);
414 start_element = take_list(list);
415 while (number < start && start_element != NULL) {
416 number++;
417 start_address = &start_element->next;
418 start_element = start_element->next;
419 } /* while */
420 if (start_element != NULL && stop >= start) {
421 stop_element = start_element;
422 while (number < stop && stop_element != NULL) {
423 number++;
424 stop_element = stop_element->next;
425 } /* while */
426 if (TEMP_OBJECT(list)) {
427 *start_address = stop_element;
428 result = start_element;
429 } else {
430 if (stop_element != NULL) {
431 saved_list_rest = stop_element->next;
432 stop_element->next = NULL;
433 result = copy_list(start_element, &err_info);
434 stop_element->next = saved_list_rest;
435 } else {
436 result = copy_list(start_element, &err_info);
437 } /* if */
438 } /* if */
439 } else {
440 result = NULL;
441 } /* if */
442 if (err_info != OKAY_NO_ERROR) {
443 return raise_exception(SYS_MEM_EXCEPTION);
444 } else {
445 return bld_list_temp(result);
446 } /* if */
447 } /* lst_range */
448
449
450
lst_tail(listType arguments)451 objectType lst_tail (listType arguments)
452
453 {
454 objectType list;
455 intType start;
456 intType number;
457 listType list_element;
458 errInfoType err_info = OKAY_NO_ERROR;
459 listType result;
460
461 /* lst_tail */
462 isit_list(arg_1(arguments));
463 isit_int(arg_3(arguments));
464 list = arg_1(arguments);
465 start = take_int(arg_3(arguments));
466 list_element = take_list(list);
467 if (start > 1 && list_element != NULL) {
468 number = 2;
469 while (number < start && list_element->next != NULL) {
470 number++;
471 list_element = list_element->next;
472 } /* while */
473 if (number >= start) {
474 if (TEMP_OBJECT(list)) {
475 result = list_element->next;
476 list_element->next = NULL;
477 } else {
478 result = copy_list(list_element->next, &err_info);
479 } /* if */
480 } else {
481 result = NULL;
482 } /* if */
483 } else {
484 if (TEMP_OBJECT(list)) {
485 result = list_element;
486 list->value.listValue = NULL;
487 } else {
488 result = copy_list(list_element, &err_info);
489 } /* if */
490 } /* if */
491 if (err_info != OKAY_NO_ERROR) {
492 return raise_exception(SYS_MEM_EXCEPTION);
493 } else {
494 return bld_list_temp(result);
495 } /* if */
496 } /* lst_tail */
497