1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2014 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/itflib.c */
23 /* Changes: 1993, 1994, 2002, 2008, 2013, 2014 Thomas Mertes */
24 /* Content: All primitive actions for interface 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 "listutl.h"
44 #include "entutl.h"
45 #include "executl.h"
46 #include "objutl.h"
47 #include "runerr.h"
48 #include "name.h"
49 #include "match.h"
50
51 #undef EXTERN
52 #define EXTERN
53 #include "itflib.h"
54
55 #undef TRACE_ITFLIB
56
57
58
59 /**
60 * Compare two interface pointers.
61 * @return -1, 0 or 1 if the first argument is considered to be
62 * respectively less than, equal to, or greater than the
63 * second.
64 */
itf_cmp(listType arguments)65 objectType itf_cmp (listType arguments)
66
67 {
68 memSizeType interface1;
69 memSizeType interface2;
70 intType signumValue;
71
72 /* itf_cmp */
73 isit_interface(arg_1(arguments));
74 isit_interface(arg_2(arguments));
75 interface1 = (memSizeType) take_interface(arg_1(arguments));
76 interface2 = (memSizeType) take_interface(arg_2(arguments));
77 if (interface1 < interface2) {
78 signumValue = -1;
79 } else {
80 signumValue = interface1 > interface2;
81 } /* if */
82 return bld_int_temp(signumValue);
83 } /* itf_cmp */
84
85
86
itf_conv2(listType arguments)87 objectType itf_conv2 (listType arguments)
88
89 {
90 objectType result;
91
92 /* itf_conv2 */
93 result = arg_3(arguments);
94 /* printf("itf_conv2: ");
95 trace1(result);
96 printf("\n"); */
97 return bld_interface_temp(result);
98 } /* itf_conv2 */
99
100
101
102 /**
103 * Assign source/arg_3 to dest/arg_1.
104 * A copy function assumes that dest/arg_1 contains a legal value.
105 */
itf_cpy(listType arguments)106 objectType itf_cpy (listType arguments)
107
108 {
109 objectType dest;
110 objectType source;
111 objectType old_value;
112 objectType new_value;
113 structType old_struct;
114
115 /* itf_cpy */
116 dest = arg_1(arguments);
117 source = arg_3(arguments);
118 isit_interface(dest);
119 /* isit_interface(source); allow FORWARDOBJECT */
120 #ifdef TRACE_ITFLIB
121 printf("itf_cpy old value: ");
122 trace1(dest);
123 printf("\n");
124 printf("itf_cpy new value: ");
125 trace1(source);
126 printf("\n");
127 #endif
128 if (CATEGORY_OF_OBJ(dest) == STRUCTOBJECT) {
129 old_struct = take_struct(dest);
130 old_value = NULL;
131 /* printf("before SET_CATEGORY: ");
132 trace1(dest);
133 printf("\n"); */
134 SET_CATEGORY_OF_OBJ(dest, INTERFACEOBJECT);
135 /* dest->value.objValue = NULL;
136 printf("after SET_CATEGORY: ");
137 trace1(dest);
138 printf("\n"); */
139 } else {
140 old_struct = NULL;
141 old_value = take_interface(dest);
142 } /* if */
143 new_value = take_interface(source);
144 if (CATEGORY_OF_OBJ(new_value) == STRUCTOBJECT) {
145 if ((TEMP_OBJECT(source) || TEMP2_OBJECT(source)) &&
146 CATEGORY_OF_OBJ(source) == STRUCTOBJECT) {
147 if (!ALLOC_OBJECT(new_value)) {
148 return raise_exception(SYS_MEM_EXCEPTION);
149 } else {
150 /* printf("itf_cpy: memcpy %lu %lu %lu ",
151 take_struct(source), new_value, source);
152 trace1(source);
153 printf("\n"); */
154 memcpy(new_value, source, sizeof(objectRecord));
155 } /* if */
156 } /* if */
157 if (new_value->value.structValue->usage_count != 0) {
158 new_value->value.structValue->usage_count++;
159 } /* if */
160 } else if (CATEGORY_OF_OBJ(new_value) != DECLAREDOBJECT &&
161 CATEGORY_OF_OBJ(new_value) != FORWARDOBJECT) {
162 run_exception(INTERFACEOBJECT, source);
163 } /* if */
164 dest->value.objValue = new_value;
165 CLEAR_TEMP_FLAG(new_value);
166 CLEAR_TEMP2_FLAG(new_value);
167 if (old_value == NULL || CATEGORY_OF_OBJ(old_value) == STRUCTOBJECT) {
168 if (old_struct == NULL) {
169 old_struct = take_struct(old_value);
170 } /* if */
171 /* printf("itf_cpy: destroy usage_count=%lu %lu\n",
172 old_struct->usage_count, (unsigned long) old_struct); */
173 if (old_struct->usage_count != 0) {
174 old_struct->usage_count--;
175 if (old_struct->usage_count == 0) {
176 destr_struct(old_struct->stru, old_struct->size);
177 /* printf("FREE_STRUCT 12 %lu\n", old_struct); */
178 FREE_STRUCT(old_struct, old_struct->size);
179 if (old_value != NULL) {
180 FREE_OBJECT(old_value);
181 } /* if */
182 } /* if */
183 } /* if */
184 } else if (CATEGORY_OF_OBJ(old_value) != DECLAREDOBJECT &&
185 CATEGORY_OF_OBJ(old_value) != FORWARDOBJECT) {
186 run_exception(INTERFACEOBJECT, old_value);
187 } /* if */
188 #ifdef TRACE_ITFLIB
189 printf("itf_cpy afterwards: ");
190 trace1(dest);
191 printf("\n");
192 #endif
193 return SYS_EMPTY_OBJECT;
194 } /* itf_cpy */
195
196
197
itf_cpy2(listType arguments)198 objectType itf_cpy2 (listType arguments)
199
200 {
201 objectType dest;
202 objectType source;
203 objectType old_value;
204 objectType new_value;
205 structType old_struct;
206
207 /* itf_cpy2 */
208 dest = arg_1(arguments);
209 source = arg_3(arguments);
210 isit_interface(dest);
211 /* isit_struct(source); allow FORWARDOBJECT */
212 if (CATEGORY_OF_OBJ(dest) == STRUCTOBJECT) {
213 old_struct = take_struct(dest);
214 old_value = NULL;
215 /* printf("before SET_CATEGORY: ");
216 trace1(dest);
217 printf("\n"); */
218 SET_CATEGORY_OF_OBJ(dest, INTERFACEOBJECT);
219 /* dest->value.objValue = NULL;
220 printf("after SET_CATEGORY: ");
221 trace1(dest);
222 printf("\n"); */
223 } else {
224 old_struct = NULL;
225 old_value = take_interface(dest);
226 } /* if */
227 new_value = source;
228 if (CATEGORY_OF_OBJ(source) == STRUCTOBJECT) {
229 if (TEMP_OBJECT(source) || TEMP2_OBJECT(source)) {
230 if (!ALLOC_OBJECT(new_value)) {
231 return raise_exception(SYS_MEM_EXCEPTION);
232 } else {
233 /* printf("itf_cpy2: memcpy %lu %lu %lu ",
234 take_struct(source), new_value, source);
235 trace1(source);
236 printf("\n"); */
237 memcpy(new_value, source, sizeof(objectRecord));
238 } /* if */
239 } /* if */
240 if (new_value->value.structValue->usage_count != 0) {
241 new_value->value.structValue->usage_count++;
242 } /* if */
243 } else if (CATEGORY_OF_OBJ(source) != DECLAREDOBJECT &&
244 CATEGORY_OF_OBJ(source) != FORWARDOBJECT) {
245 run_exception(STRUCTOBJECT, source);
246 } /* if */
247 dest->value.objValue = new_value;
248 CLEAR_TEMP_FLAG(new_value);
249 CLEAR_TEMP2_FLAG(new_value);
250 if (old_value == NULL || CATEGORY_OF_OBJ(old_value) == STRUCTOBJECT) {
251 if (old_struct == NULL) {
252 old_struct = take_struct(old_value);
253 } /* if */
254 /* printf("itf_cpy2: destroy usage_count=%lu %lu\n",
255 old_struct->usage_count, (unsigned long) old_struct); */
256 if (old_struct->usage_count != 0) {
257 old_struct->usage_count--;
258 if (old_struct->usage_count == 0) {
259 destr_struct(old_struct->stru, old_struct->size);
260 /* printf("FREE_STRUCT 13 %lu\n", old_struct); */
261 FREE_STRUCT(old_struct, old_struct->size);
262 if (old_value != NULL) {
263 FREE_OBJECT(old_value);
264 } /* if */
265 } /* if */
266 } /* if */
267 } else if (CATEGORY_OF_OBJ(old_value) != DECLAREDOBJECT &&
268 CATEGORY_OF_OBJ(old_value) != FORWARDOBJECT) {
269 run_exception(INTERFACEOBJECT, old_value);
270 } /* if */
271 return SYS_EMPTY_OBJECT;
272 } /* itf_cpy2 */
273
274
275
276 /**
277 * Initialize dest/arg_1 and assign source/arg_3 to it.
278 * A create function assumes that the contents of dest/arg_1
279 * is undefined. Create functions can be used to initialize
280 * constants.
281 */
itf_create(listType arguments)282 objectType itf_create (listType arguments)
283
284 {
285 objectType dest;
286 objectType source;
287 objectType new_value;
288
289 /* itf_create */
290 dest = arg_1(arguments);
291 source = arg_3(arguments);
292 /* isit_interface(source); allow FORWARDOBJECT */
293 SET_CATEGORY_OF_OBJ(dest, INTERFACEOBJECT);
294 #ifdef TRACE_ITFLIB
295 printf("itf_create from: ");
296 trace1(source);
297 printf("\n");
298 #endif
299 new_value = take_interface(source);
300 if (CATEGORY_OF_OBJ(new_value) == STRUCTOBJECT) {
301 if ((TEMP_OBJECT(source) || TEMP2_OBJECT(source)) &&
302 CATEGORY_OF_OBJ(source) == STRUCTOBJECT) {
303 if (!ALLOC_OBJECT(new_value)) {
304 return raise_exception(SYS_MEM_EXCEPTION);
305 } else {
306 /* printf("itf_create: memcpy %lu %lu %lu ",
307 take_struct(source), new_value, source);
308 trace1(source);
309 printf("\n"); */
310 memcpy(new_value, source, sizeof(objectRecord));
311 } /* if */
312 } else {
313 isit_struct_ok(new_value);
314 } /* if */
315 if (new_value->value.structValue->usage_count != 0) {
316 new_value->value.structValue->usage_count++;
317 } /* if */
318 } else if (CATEGORY_OF_OBJ(new_value) != DECLAREDOBJECT &&
319 CATEGORY_OF_OBJ(new_value) != FORWARDOBJECT) {
320 run_exception(INTERFACEOBJECT, source);
321 } /* if */
322 dest->value.objValue = new_value;
323 CLEAR_TEMP_FLAG(new_value);
324 CLEAR_TEMP2_FLAG(new_value);
325 #ifdef TRACE_ITFLIB
326 printf("itf_create to: ");
327 trace1(dest);
328 printf("\n");
329 #endif
330 return SYS_EMPTY_OBJECT;
331 } /* itf_create */
332
333
334
itf_create2(listType arguments)335 objectType itf_create2 (listType arguments)
336
337 {
338 objectType dest;
339 objectType source;
340 objectType new_value;
341
342 /* itf_create2 */
343 dest = arg_1(arguments);
344 source = arg_3(arguments);
345 /* isit_interface(source); allow FORWARDOBJECT */
346 SET_CATEGORY_OF_OBJ(dest, INTERFACEOBJECT);
347 #ifdef TRACE_ITFLIB
348 printf("itf_create2 from: ");
349 trace1(source);
350 printf("\n");
351 #endif
352 new_value = source;
353 if (CATEGORY_OF_OBJ(new_value) == STRUCTOBJECT) {
354 if (TEMP_OBJECT(source) || TEMP2_OBJECT(source)) {
355 if (!ALLOC_OBJECT(new_value)) {
356 return raise_exception(SYS_MEM_EXCEPTION);
357 } else {
358 /* printf("itf_create2: memcpy %lu %lu %lu ",
359 take_struct(source), new_value, source);
360 trace1(source);
361 printf("\n"); */
362 memcpy(new_value, source, sizeof(objectRecord));
363 } /* if */
364 } /* if */
365 if (new_value->value.structValue->usage_count != 0) {
366 new_value->value.structValue->usage_count++;
367 } /* if */
368 } else if (CATEGORY_OF_OBJ(new_value) != DECLAREDOBJECT &&
369 CATEGORY_OF_OBJ(new_value) != FORWARDOBJECT) {
370 run_exception(STRUCTOBJECT, source);
371 } /* if */
372 dest->value.objValue = new_value;
373 CLEAR_TEMP_FLAG(new_value);
374 CLEAR_TEMP2_FLAG(new_value);
375 #ifdef TRACE_ITFLIB
376 printf("itf_create2 to: ");
377 trace1(dest);
378 printf("\n");
379 #endif
380 return SYS_EMPTY_OBJECT;
381 } /* itf_create2 */
382
383
384
385 /**
386 * Free the memory referred by 'old_value/arg_1'.
387 * After itf_destr is left 'old_value/arg_1' is NULL.
388 * The memory where 'old_value/arg_1' is stored can be
389 * freed afterwards.
390 */
itf_destr(listType arguments)391 objectType itf_destr (listType arguments)
392
393 {
394 objectType old_value;
395 structType old_struct;
396
397 /* itf_destr */
398 #ifdef TRACE_ITFLIB
399 printf("itf_destr(");
400 trace1(arg_1(arguments));
401 printf("\n");
402 #endif
403 just_interface(arg_1(arguments));
404 old_value = take_interface(arg_1(arguments));
405 if (old_value != NULL) {
406 isit_struct(old_value);
407 old_struct = take_struct(old_value);
408 if (old_struct != NULL) {
409 /* printf("itf_destr: usage_count=%lu %lu\n",
410 old_struct->usage_count, (unsigned long) old_struct);
411 trace1(old_value);
412 printf("\n"); */
413 if (old_struct->usage_count != 0) {
414 old_struct->usage_count--;
415 if (old_struct->usage_count == 0) {
416 destr_struct(old_struct->stru, old_struct->size);
417 /* printf("FREE_STRUCT 14 %lu\n", old_struct); */
418 FREE_STRUCT(old_struct, old_struct->size);
419 arg_1(arguments)->value.objValue = NULL;
420 /* The function close_stack leaves HAS_PROPERTY intact to */
421 /* allow checking for it here. Just objects without property */
422 /* are removed here. Objects with property will be removed */
423 /* by close_stack or by other functions. */
424 if (HAS_PROPERTY(old_value)) {
425 old_value->value.structValue = NULL;
426 /* printf("itf_destr: Struct object with property ");
427 trace1(old_value);
428 printf("\n"); */
429 } else {
430 FREE_OBJECT(old_value);
431 } /* if */
432 } /* if */
433 } /* if */
434 } /* if */
435 arg_1(arguments)->value.objValue = NULL;
436 } /* if */
437 SET_UNUSED_FLAG(arg_1(arguments));
438 return SYS_EMPTY_OBJECT;
439 } /* itf_destr */
440
441
442
443 /**
444 * Check if two interfaces are equal.
445 * @return TRUE if both interfaces are equal,
446 * FALSE otherwise.
447 */
itf_eq(listType arguments)448 objectType itf_eq (listType arguments)
449
450 { /* itf_eq */
451 isit_interface(arg_1(arguments));
452 isit_interface(arg_3(arguments));
453 if (take_interface(arg_1(arguments)) ==
454 take_interface(arg_3(arguments))) {
455 return SYS_TRUE_OBJECT;
456 } else {
457 return SYS_FALSE_OBJECT;
458 } /* if */
459 } /* itf_eq */
460
461
462
463 /**
464 * Compute the hash value of an interface.
465 * @return the hash value.
466 */
itf_hashcode(listType arguments)467 objectType itf_hashcode (listType arguments)
468
469 { /* itf_hashcode */
470 isit_interface(arg_1(arguments));
471 return bld_int_temp((intType)
472 (((memSizeType) take_interface(arg_1(arguments))) >> 6));
473 } /* itf_hashcode */
474
475
476
477 /**
478 * Check if two interfaces are not equal.
479 * @return FALSE if both interfaces are equal,
480 * TRUE otherwise.
481 */
itf_ne(listType arguments)482 objectType itf_ne (listType arguments)
483
484 { /* itf_ne */
485 isit_interface(arg_1(arguments));
486 isit_interface(arg_3(arguments));
487 if (take_interface(arg_1(arguments)) !=
488 take_interface(arg_3(arguments))) {
489 return SYS_TRUE_OBJECT;
490 } else {
491 return SYS_FALSE_OBJECT;
492 } /* if */
493 } /* itf_ne */
494
495
496
itf_new(listType arguments)497 objectType itf_new (listType arguments)
498
499 {
500 objectType stru_arg;
501 structType stru1;
502 structType result_struct;
503 objectType result;
504
505 /* itf_new */
506 stru_arg = arg_1(arguments);
507 isit_struct(stru_arg);
508 if (TEMP_OBJECT(stru_arg)) {
509 result = stru_arg;
510 result->type_of = NULL;
511 arg_1(arguments) = NULL;
512 } else {
513 stru1 = take_struct(stru_arg);
514 if (!ALLOC_STRUCT(result_struct, stru1->size)) {
515 return raise_exception(SYS_MEM_EXCEPTION);
516 } /* if */
517 result_struct->usage_count = 1;
518 result_struct->size = stru1->size;
519 if (!crea_struct(result_struct->stru, stru1->stru, stru1->size)) {
520 /* printf("FREE_STRUCT 15 %lu\n", result_struct); */
521 FREE_STRUCT(result_struct, stru1->size);
522 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
523 } /* if */
524 result = bld_struct_temp(result_struct);
525 } /* if */
526 return result;
527 } /* itf_new */
528
529
530
itf_select(listType arguments)531 objectType itf_select (listType arguments)
532
533 {
534 structType stru1;
535 objectType selector;
536 objectType selector_syobject;
537 memSizeType position;
538 objectType struct_pointer;
539
540 /* itf_select */
541 isit_struct(arg_1(arguments));
542 stru1 = take_struct(arg_1(arguments));
543 selector = arg_3(arguments);
544 /*
545 printf("stru1 ");
546 trace1(arg_1(arguments));
547 printf("\n");
548 printf("selector ");
549 trace1(selector);
550 printf("\n");
551 */
552 if (HAS_ENTITY(selector) &&
553 GET_ENTITY(selector)->syobject != NULL) {
554 selector_syobject = GET_ENTITY(selector)->syobject;
555 position = stru1->size;
556 struct_pointer = stru1->stru;
557 while (position > 0) {
558 /*
559 printf("test ");
560 trace1(struct_pointer);
561 printf("\n");
562 */
563 if (HAS_ENTITY(struct_pointer) &&
564 GET_ENTITY(struct_pointer)->syobject == selector_syobject) {
565 if (TEMP_OBJECT(struct_pointer)) {
566 printf("sct_select of TEMP_OBJECT\n");
567 } /* if */
568 return struct_pointer;
569 } /* if */
570 position--;
571 struct_pointer++;
572 } /* while */
573 } /* if */
574 logError(printf("itf_select(");
575 trace1(arg_1(arguments));
576 printf(", ");
577 trace1(arg_3(arguments));
578 printf("): Selector not found.\n"););
579 return raise_exception(SYS_RNG_EXCEPTION);
580 } /* itf_select */
581
582
583
itf_to_interface(listType arguments)584 objectType itf_to_interface (listType arguments)
585
586 {
587 objectType stru_arg;
588 objectType new_value;
589 objectType result;
590
591 /* itf_to_interface */
592 stru_arg = arg_1(arguments);
593 #ifdef TRACE_ITFLIB
594 printf("itf_to_interface: ");
595 trace1(stru_arg);
596 printf("\n");
597 #endif
598 isit_struct(stru_arg);
599 if (!ALLOC_OBJECT(new_value)) {
600 return raise_exception(SYS_MEM_EXCEPTION);
601 } else {
602 memcpy(new_value, stru_arg, sizeof(objectRecord));
603 CLEAR_TEMP_FLAG(new_value);
604 CLEAR_TEMP2_FLAG(new_value);
605 if (new_value->value.structValue->usage_count != 0) {
606 new_value->value.structValue->usage_count++;
607 } /* if */
608 } /* if */
609 result = bld_interface_temp(new_value);
610 #ifdef TRACE_ITFLIB
611 printf("itf_to_interface --> ");
612 trace1(result);
613 printf("\n");
614 #endif
615 return result;
616 } /* itf_to_interface */
617