1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2004, 2011 - 2015, 2017 Thomas Mertes */
5 /* 2019 - 2021 Thomas Mertes */
6 /* */
7 /* This program is free software; you can redistribute it and/or */
8 /* modify it under the terms of the GNU General Public License as */
9 /* published by the Free Software Foundation; either version 2 of */
10 /* the License, or (at your option) any later version. */
11 /* */
12 /* This program is distributed in the hope that it will be useful, */
13 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
14 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
15 /* GNU General Public License for more details. */
16 /* */
17 /* You should have received a copy of the GNU General Public */
18 /* License along with this program; if not, write to the */
19 /* Free Software Foundation, Inc., 51 Franklin Street, */
20 /* Fifth Floor, Boston, MA 02110-1301, USA. */
21 /* */
22 /* Module: Interpreter */
23 /* File: seed7/src/exec.c */
24 /* Changes: 1999, 2000, 2004, 2011 - 2015, 2017 Thomas Mertes */
25 /* 2019 - 2021 Thomas Mertes */
26 /* Content: Main interpreter procedures. */
27 /* */
28 /********************************************************************/
29
30 #define LOG_FUNCTIONS 0
31 #define VERBOSE_EXCEPTIONS 0
32
33 #include "version.h"
34
35 #include "stdlib.h"
36 #include "stdio.h"
37 #include "string.h"
38
39 #include "common.h"
40 #include "data.h"
41 #include "sigutl.h"
42 #include "heaputl.h"
43 #include "flistutl.h"
44 #include "datautl.h"
45 #include "entutl.h"
46 #include "syvarutl.h"
47 #include "listutl.h"
48 #include "traceutl.h"
49 #include "actutl.h"
50 #include "executl.h"
51 #include "objutl.h"
52 #include "runerr.h"
53 #include "match.h"
54 #include "prclib.h"
55
56 #undef EXTERN
57 #define EXTERN
58 #define DO_INIT
59 #include "exec.h"
60
61
62 extern boolType interpreter_exception;
63
64
65
doSuspendInterpreter(int signalNum)66 void doSuspendInterpreter (int signalNum)
67
68 { /* doSuspendInterpreter */
69 logFunction(printf("doSuspendInterpreter(%d)\n", signalNum););
70 interrupt_flag = TRUE;
71 signal_number = signalNum;
72 } /* doSuspendInterpreter */
73
74
75
exec_object(register objectType object)76 objectType exec_object (register objectType object)
77
78 {
79 register objectType result;
80
81 /* exec_object */
82 logFunction(printf("exec_object ");
83 trace1(object);
84 printf("\n"););
85 switch (CATEGORY_OF_OBJ(object)) {
86 case CALLOBJECT:
87 result = exec_call(object);
88 #ifdef OUT_OF_ORDER
89 if (fail_flag) {
90 printf("propagate exception ");
91 trace1(object);
92 printf("\n"); */
93 } /* if */
94 #endif
95 break;
96 case VALUEPARAMOBJECT:
97 case REFPARAMOBJECT:
98 case RESULTOBJECT:
99 case LOCALVOBJECT:
100 if (object->value.objValue != NULL) {
101 result = object->value.objValue;
102 } else {
103 result = object;
104 } /* if */
105 break;
106 case MATCHOBJECT:
107 /* This is NONSENSE:
108 printf("exec_object1: MATCHOBJECT ");
109 trace1(object);
110 printf("\n");
111 result = object->value.listValue->obj;
112 printf("exec_object2: MATCHOBJECT ");
113 trace1(result);
114 printf("\n");
115 break; */
116 case DECLAREDOBJECT:
117 case SYMBOLOBJECT:
118 case BLOCKOBJECT:
119 case TYPEOBJECT:
120 case INTOBJECT:
121 case BIGINTOBJECT:
122 case CHAROBJECT:
123 case STRIOBJECT:
124 case BSTRIOBJECT:
125 case ARRAYOBJECT:
126 case HASHOBJECT:
127 case STRUCTOBJECT:
128 case FILEOBJECT:
129 case LISTOBJECT:
130 #if WITH_FLOAT
131 case FLOATOBJECT:
132 #endif
133 case WINOBJECT:
134 case REFOBJECT:
135 case REFLISTOBJECT:
136 case EXPROBJECT:
137 case ACTOBJECT:
138 case ENUMLITERALOBJECT:
139 case VARENUMOBJECT:
140 result = object;
141 break;
142 default:
143 /* printf("exec_object unknown ");
144 trace1(object);
145 printf("\n"); */
146 result = object;
147 break;
148 } /* switch */
149 logFunction(printf("exec_object --> ");
150 trace1(result);
151 printf("\n"););
152 return result;
153 } /* exec_object */
154
155
156
157 /**
158 * When a temporary value is entered into a reference parameter
159 * the TEMP flag must be cleared. This is necessary to avoid
160 * destroying the value inside the function before the end of
161 * the function is reached. Such temporary values are removed
162 * upon function exit by par_restore. When the TEMP flag
163 * is cleared for a temporary reference parameter the TEMP2
164 * flag is set instead. Note that there is no other place
165 * where the TEMP2 flag is set. This TEMP2 flag can be used
166 * by primitive actions like hsh_cpy, hsh_create, hsh_idx
167 * or arr_sort to avoid unnecessary copying of data values.
168 * This must be done with care, because the calling function
169 * cannot access the parameter after the primitive action was
170 * executed. For the actions mentioned above the surrounding
171 * functions are defined in seed7_05.s7i and take care of this.
172 * When a TEMP2 parameter is used for a deeper function call
173 * The TEMP2 flag is cleared to avoid unwanted effects.
174 */
par_init(locListType form_param_list,listType * backup_form_params,listType act_param_list,listType * evaluated_act_params)175 static inline void par_init (locListType form_param_list,
176 listType *backup_form_params, listType act_param_list,
177 listType *evaluated_act_params)
178
179 {
180 locListType form_param;
181 listType *backup_insert_place;
182 listType *evaluated_insert_place;
183 listType param_list_elem;
184 objectType param_value;
185 errInfoType err_info = OKAY_NO_ERROR;
186
187 /* par_init */
188 logFunction(printf("par_init\n"););
189 form_param = form_param_list;
190 *backup_form_params = NULL;
191 backup_insert_place = backup_form_params;
192 *evaluated_act_params = NULL;
193 evaluated_insert_place = evaluated_act_params;
194 while (form_param != NULL && !fail_flag) {
195 append_to_list(backup_insert_place,
196 form_param->local.object->value.objValue, act_param_list);
197 param_value = exec_object(act_param_list->obj);
198 append_to_list(evaluated_insert_place, param_value, act_param_list);
199 form_param = form_param->next;
200 act_param_list = act_param_list->next;
201 } /* while */
202 if (fail_flag) {
203 param_list_elem = *evaluated_act_params;
204 while (param_list_elem != NULL) {
205 if (param_list_elem->obj != NULL && TEMP_OBJECT(param_list_elem->obj)) {
206 dump_any_temp(param_list_elem->obj);
207 } /* if */
208 param_list_elem = param_list_elem->next;
209 } /* while */
210 } else {
211 form_param = form_param_list;
212 param_list_elem = *evaluated_act_params;
213 while (form_param != NULL && err_info == OKAY_NO_ERROR) {
214 param_value = param_list_elem->obj;
215 switch (CATEGORY_OF_OBJ(form_param->local.object)) {
216 case VALUEPARAMOBJECT:
217 /* printf("value param formal ");
218 trace1(form_param->local.object);
219 printf(" %lu\nparam value ", (unsigned long) form_param->local.object);
220 trace1(param_value);
221 printf(" %lu\n", (unsigned long) param_value); */
222 if (TEMP_OBJECT(param_value)) {
223 CLEAR_TEMP_FLAG(param_value);
224 COPY_VAR_FLAG(param_value, form_param->local.object);
225 form_param->local.object->value.objValue = param_value;
226 param_list_elem->obj = NULL;
227 /* printf("assign temp ");
228 trace1(form_param->local.object);
229 printf(" %lu\n", (unsigned long) form_param->local.object); */
230 } else {
231 CLEAR_TEMP2_FLAG(param_value);
232 create_local_object(&form_param->local, param_value, &err_info);
233 /* printf("assign obj ");
234 trace1(form_param->local.object);
235 printf(" %lu\n", (unsigned long) form_param->local.object); */
236 } /* if */
237 break;
238 case REFPARAMOBJECT:
239 /* printf("ref param formal ");
240 trace1(form_param->local.object);
241 printf(" %lu\nparam value ", (unsigned long) form_param->local.object);
242 trace1(param_value);
243 printf(" %lu\n", (unsigned long) param_value); */
244 form_param->local.object->value.objValue = param_value;
245 if (TEMP_OBJECT(param_value)) {
246 CLEAR_TEMP_FLAG(param_value);
247 SET_TEMP2_FLAG(param_value);
248 /* printf("ref to temp ");
249 trace1(form_param->local.object);
250 printf(" %lu\n", (unsigned long) form_param->local.object); */
251 } else {
252 CLEAR_TEMP2_FLAG(param_value);
253 param_list_elem->obj = NULL;
254 } /* if */
255 break;
256 default:
257 /* Do nothing for SYMBOLOBJECT and TYPEOBJECT. */
258 break;
259 } /* switch */
260 form_param = form_param->next;
261 param_list_elem = param_list_elem->next;
262 } /* while */
263 } /* if */
264 logFunction(printf("par_init -->\n"););
265 } /* par_init */
266
267
268
par_restore(const_locListType form_param,const_listType backup_form_params,const_listType evaluated_act_params)269 static inline void par_restore (const_locListType form_param,
270 const_listType backup_form_params, const_listType evaluated_act_params)
271
272 {
273 failStateStruct savedFailState;
274
275 /* par_restore */
276 logFunction(printf("par_restore\n"););
277 if (unlikely(fail_flag)) {
278 saveFailState(&savedFailState);
279 while (form_param != NULL) {
280 switch (CATEGORY_OF_OBJ(form_param->local.object)) {
281 case VALUEPARAMOBJECT:
282 destroy_local_object(&form_param->local, TRUE);
283 break;
284 case REFPARAMOBJECT:
285 if (evaluated_act_params->obj != NULL) {
286 dump_any_temp(evaluated_act_params->obj);
287 } /* if */
288 break;
289 default:
290 /* Do nothing for SYMBOLOBJECT and TYPEOBJECT. */
291 break;
292 } /* switch */
293 form_param->local.object->value.objValue = backup_form_params->obj;
294 form_param = form_param->next;
295 backup_form_params = backup_form_params->next;
296 evaluated_act_params = evaluated_act_params->next;
297 } /* while */
298 restoreFailState(&savedFailState);
299 } else {
300 while (form_param != NULL) {
301 if (!fail_flag) {
302 switch (CATEGORY_OF_OBJ(form_param->local.object)) {
303 case VALUEPARAMOBJECT:
304 destroy_local_object(&form_param->local, FALSE);
305 break;
306 case REFPARAMOBJECT:
307 if (evaluated_act_params->obj != NULL) {
308 dump_any_temp(evaluated_act_params->obj);
309 } /* if */
310 break;
311 default:
312 /* Do nothing for SYMBOLOBJECT and TYPEOBJECT. */
313 break;
314 } /* switch */
315 } /* if */
316 form_param->local.object->value.objValue = backup_form_params->obj;
317 form_param = form_param->next;
318 backup_form_params = backup_form_params->next;
319 evaluated_act_params = evaluated_act_params->next;
320 } /* while */
321 } /* if */
322 logFunction(printf("par_restore -->\n"););
323 } /* par_restore */
324
325
326
loc_init(const_locListType loc_var,listType * backup_loc_var,listType act_param_list)327 static void loc_init (const_locListType loc_var, listType *backup_loc_var,
328 listType act_param_list)
329
330 {
331 listType *list_insert_place;
332 errInfoType err_info = OKAY_NO_ERROR;
333
334 /* loc_init */
335 logFunction(printf("loc_init\n"););
336 *backup_loc_var = NULL;
337 list_insert_place = backup_loc_var;
338 while (loc_var != NULL && !fail_flag) {
339 append_to_list(list_insert_place,
340 loc_var->local.object->value.objValue, act_param_list);
341 create_local_object(&loc_var->local, loc_var->local.init_value, &err_info);
342 loc_var = loc_var->next;
343 } /* while */
344 logFunction(printf("loc_init -->\n"););
345 } /* loc_init */
346
347
348
loc_restore(const_locListType loc_var,const_listType backup_loc_var)349 static void loc_restore (const_locListType loc_var, const_listType backup_loc_var)
350
351 {
352 failStateStruct savedFailState;
353
354 /* loc_restore */
355 logFunction(printf("loc_restore\n"););
356 if (unlikely(fail_flag)) {
357 saveFailState(&savedFailState);
358 while (loc_var != NULL) {
359 destroy_local_object(&loc_var->local, TRUE);
360 loc_var->local.object->value.objValue = backup_loc_var->obj;
361 loc_var = loc_var->next;
362 backup_loc_var = backup_loc_var->next;
363 } /* while */
364 restoreFailState(&savedFailState);
365 } else {
366 while (loc_var != NULL) {
367 if (likely(!fail_flag)) {
368 destroy_local_object(&loc_var->local, FALSE);
369 } /* if */
370 loc_var->local.object->value.objValue = backup_loc_var->obj;
371 loc_var = loc_var->next;
372 backup_loc_var = backup_loc_var->next;
373 } /* while */
374 } /* if */
375 logFunction(printf("loc_restore -->\n"););
376 } /* loc_restore */
377
378
379
res_init(const_locObjType block_result,objectType * backup_block_result)380 static inline boolType res_init (const_locObjType block_result,
381 objectType *backup_block_result)
382
383 {
384 errInfoType err_info = OKAY_NO_ERROR;
385
386 /* res_init */
387 logFunction(printf("res_init\n"););
388 /* printf("block_result ");
389 trace1(block_result->object);
390 printf("\n");
391 printf("result_init ");
392 trace1(block_result->init_value);
393 printf("\n"); */
394 if (block_result->object != NULL) {
395 /* Backup_block_result is initialized in res_init and used in */
396 /* res_restore. Backup_block_result is initialized and used */
397 /* conditionally. In both cases (initialisation and use) the */
398 /* same condition is used. Possible compiler warnings that */
399 /* "it may be used uninitialized" can be ignored. */
400 *backup_block_result = block_result->object->value.objValue;
401 create_local_object(block_result, block_result->init_value, &err_info);
402 } /* if */
403 logFunction(printf("res_init(" FMT_U_MEM ") -->\n",
404 block_result->object != NULL ?
405 ((memSizeType) block_result->object->value.objValue) : 0););
406 return err_info == OKAY_NO_ERROR;
407 } /* res_init */
408
409
410
res_restore(const_locObjType block_result,objectType backup_block_result,objectType * result)411 static inline void res_restore (const_locObjType block_result,
412 objectType backup_block_result, objectType *result)
413
414 {
415 errInfoType err_info = OKAY_NO_ERROR;
416
417 /* res_restore */
418 logFunction(printf("res_restore\n"););
419 if (block_result->object != NULL) {
420 if (fail_flag) {
421 dump_any_temp(block_result->object->value.objValue);
422 } else {
423 *result = block_result->object->value.objValue;
424 /* CLEAR_VAR_FLAG(*result); */
425 SET_TEMP_FLAG(*result);
426 } /* if */
427 /* Backup_block_result is initialized in res_init and used in */
428 /* res_restore. Backup_block_result is initialized and used */
429 /* conditionally. In both cases (initialisation and use) the */
430 /* same condition is used. Possible compiler warnings that */
431 /* "it may be used uninitialized" can be ignored. */
432 block_result->object->value.objValue = backup_block_result;
433 } else if (*result != NULL && !TEMP_OBJECT(*result) &&
434 CATEGORY_OF_OBJ(*result) != ENUMLITERALOBJECT) {
435 #ifdef OUT_OF_ORDER
436 printf("return non temp ");
437 trace1(*result);
438 printf("\n");
439 #endif
440 if (block_result->create_call_obj != NULL) {
441 *result = create_return_object(block_result, *result, &err_info);
442 SET_TEMP_FLAG(*result);
443 } /* if */
444 } /* if */
445 logFunction(printf("res_restore(" FMT_U_MEM ") -->\n",
446 (memSizeType) *result););
447 } /* res_restore */
448
449
450
451 #ifdef OUT_OF_ORDER
show_arg_list(listType act_param_list)452 static void show_arg_list (listType act_param_list)
453
454 { /* show_arg_list */
455 while (act_param_list != NULL) {
456 if (act_param_list->obj != NULL) {
457 #ifdef WITH_PROTOCOL
458 if (trace.actions) {
459 prot_cstri("show_arg_list ");
460 printcategory(CATEGORY_OF_OBJ(act_param_list->obj));
461 prot_cstri(" ");
462 prot_int((intType) act_param_list->obj);
463 prot_cstri(" ");
464 trace1(act_param_list->obj);
465 prot_nl();
466 } /* if */
467 #endif
468 } else {
469 #ifdef WITH_PROTOCOL
470 if (trace.actions) {
471 prot_cstri("show_arg_list NULL");
472 prot_nl();
473 } /* if */
474 #endif
475 } /* if */
476 act_param_list = act_param_list->next;
477 } /* while */
478 } /* show_arg_list */
479 #endif
480
481
482
exec_lambda(const_blockType block,listType actual_parameters,objectType object)483 static objectType exec_lambda (const_blockType block,
484 listType actual_parameters, objectType object)
485
486 {
487 objectType result;
488 listType evaluated_act_params;
489 listType backup_form_params;
490 objectType backup_block_result;
491 listType backup_loc_var;
492
493 /* exec_lambda */
494 logFunction(printf("exec_lambda\n"););
495 par_init(block->params, &backup_form_params, actual_parameters,
496 &evaluated_act_params);
497 if (fail_flag) {
498 free_list(backup_form_params);
499 free_list(evaluated_act_params);
500 result = fail_value;
501 } else {
502 loc_init(block->local_vars, &backup_loc_var, actual_parameters);
503 if (fail_flag) {
504 free_list(backup_loc_var);
505 result = fail_value;
506 } else {
507 if (res_init(&block->result, &backup_block_result)) {
508 result = exec_call(block->body);
509 if (fail_flag) {
510 errInfoType ignored_err_info;
511
512 /* ignored_err_info is not checked since an exception was already raised */
513 incl_list(&fail_stack, object, &ignored_err_info);
514 } /* if */
515 res_restore(&block->result, backup_block_result, &result);
516 } else {
517 result = raise_with_arguments(SYS_MEM_EXCEPTION, actual_parameters);
518 } /* if */
519 loc_restore(block->local_vars, backup_loc_var);
520 free_list(backup_loc_var);
521 } /* if */
522 /* show_arg_list(evaluated_act_params); */
523 par_restore(block->params, backup_form_params, evaluated_act_params);
524 free_list(backup_form_params);
525 free_list(evaluated_act_params);
526 } /* if */
527 logFunction(printf("exec_lambda -->\n"););
528 return result;
529 } /* exec_lambda */
530
531
532
eval_arg_list(register listType act_param_list,uint32Type * temp_bits_ptr)533 static listType eval_arg_list (register listType act_param_list, uint32Type *temp_bits_ptr)
534
535 {
536 listType evaluated_act_params = NULL;
537 register objectType evaluated_object;
538 register listType *evaluated_insert_place;
539 uint32Type temp_bits = 0;
540 int param_num = 0;
541
542 /* eval_arg_list */
543 evaluated_insert_place = &evaluated_act_params;
544 while (act_param_list != NULL && !fail_flag) {
545 evaluated_object = exec_object(act_param_list->obj);
546 append_to_list(evaluated_insert_place, evaluated_object, act_param_list);
547 if (evaluated_object != NULL && TEMP_OBJECT(evaluated_object)) {
548 temp_bits |= (uint32Type) 1 << param_num;
549 } /* if */
550 act_param_list = act_param_list->next;
551 param_num++;
552 } /* while */
553 *temp_bits_ptr = temp_bits;
554 return evaluated_act_params;
555 } /* eval_arg_list */
556
557
558
dump_arg_list(listType evaluated_act_params,uint32Type temp_bits)559 static void dump_arg_list (listType evaluated_act_params, uint32Type temp_bits)
560
561 {
562 register listType list_end;
563
564 /* dump_arg_list */
565 if (evaluated_act_params != NULL) {
566 list_end = evaluated_act_params;
567 while (list_end->next != NULL) {
568 if (list_end->obj != NULL && temp_bits & 1 && TEMP_OBJECT(list_end->obj)) {
569 dump_any_temp(list_end->obj);
570 } /* if */
571 list_end = list_end->next;
572 temp_bits >>= 1;
573 } /* while */
574 if (list_end->obj != NULL && temp_bits & 1 && TEMP_OBJECT(list_end->obj)) {
575 dump_any_temp(list_end->obj);
576 } /* if */
577 free_list2(evaluated_act_params, list_end);
578 } /* if */
579 } /* dump_arg_list */
580
581
582
exec_action(const_objectType act_object,listType act_param_list,objectType object)583 static objectType exec_action (const_objectType act_object,
584 listType act_param_list, objectType object)
585
586 {
587 listType evaluated_act_params;
588 uint32Type temp_bits;
589 objectType result;
590
591 /* exec_action */
592 logFunction(printf("exec_action(%s)\n",
593 getActEntry(act_object->value.actValue)->name););
594 #if CHECK_STACK
595 if (checkStack(FALSE)) {
596 return raise_with_arguments(SYS_MEM_EXCEPTION, act_param_list);
597 } /* if */
598 #endif
599 evaluated_act_params = eval_arg_list(act_param_list, &temp_bits);
600 if (interrupt_flag) {
601 if (!fail_flag) {
602 curr_exec_object = object;
603 curr_argument_list = evaluated_act_params;
604 show_signal();
605 } /* if */
606 if (fail_flag) {
607 dump_arg_list(evaluated_act_params, temp_bits);
608 result = fail_value;
609 logFunction(printf("exec_action fail_flag=%d -->\n", fail_flag););
610 return result;
611 } /* if */
612 } /* if */
613 #if WITH_ACTION_CHECK
614 if (trace.check_actions) {
615 if (unlikely(act_object->value.actValue == actTable.table[0].action)) {
616 logError(printf("evaluate: illegal action\n"););
617 result = raise_with_arguments(SYS_ACT_ILLEGAL_EXCEPTION,
618 evaluated_act_params);
619 } /* if */
620 } /* if */
621 #endif
622 #ifdef WITH_PROTOCOL
623 if (trace.actions) {
624 /* heapStatistic(); */
625 if (trace.heapsize) {
626 prot_heapsize();
627 prot_cstri(" ");
628 } /* if */
629 prot_cstri(getActEntry(act_object->value.actValue)->name);
630 /* prot_cstri("(");
631 prot_list(act_param_list);
632 prot_cstri(") "); */
633 prot_cstri("(");
634 prot_list(evaluated_act_params);
635 prot_cstri(") ");
636 prot_flush();
637 /* curr_action_object = act_object; */
638 curr_exec_object = object;
639 curr_argument_list = evaluated_act_params;
640 result = (*(act_object->value.actValue))(evaluated_act_params);
641 if (act_object->type_of != NULL) {
642 if (act_object->type_of->result_type != NULL) {
643 if (result != NULL) {
644 if (result->type_of != act_object->type_of->result_type) {
645 prot_cstri("** correct action result type from \'");
646 if (result->type_of == NULL) {
647 prot_cstri("*NULL_TYPE*");
648 } else {
649 printobject(result->type_of->match_obj);
650 } /* if */
651 prot_cstri("\' to \'");
652 printobject(act_object->type_of->result_type->match_obj);
653 prot_cstri("\' act_object type is ");
654 printobject(act_object->type_of->match_obj);
655 } /* if */
656 if (result->type_of == NULL) {
657 result->type_of = act_object->type_of->result_type;
658 } /* if */
659 } else {
660 prot_cstri("** result == NULL for action ");
661 prot_cstri(getActEntry(act_object->value.actValue)->name);
662 } /* if */
663 } else {
664 prot_cstri("** act_object->type_of->result_type == NULL ");
665 } /* if */
666 } else {
667 prot_cstri("** act_object->type_of == NULL ");
668 } /* if */
669 prot_cstri(" ==> ");
670 printobject(result);
671 if (trace.heapsize) {
672 prot_cstri(" ");
673 prot_heapsize();
674 } /* if */
675 prot_nl();
676 prot_flush();
677 } else {
678 #endif
679 /* curr_action_object = act_object; */
680 curr_exec_object = object;
681 curr_argument_list = evaluated_act_params;
682 result = (*(act_object->value.actValue))(evaluated_act_params);
683 if (result != NULL && result->type_of == NULL) {
684 result->type_of = act_object->type_of->result_type;
685 } /* if */
686 #ifdef WITH_PROTOCOL
687 } /* if */
688 #endif
689 dump_arg_list(evaluated_act_params, temp_bits);
690 logFunction(printf("exec_action fail_flag=%d -->\n", fail_flag););
691 return result;
692 } /* exec_action */
693
694
695
exec_all_parameters(const_listType act_param_list)696 static void exec_all_parameters (const_listType act_param_list)
697
698 { /* exec_all_parameters */
699 logFunction(printf("exec_all_parameters\n"););
700 while (act_param_list != NULL && !fail_flag) {
701 exec_object(act_param_list->obj);
702 act_param_list = act_param_list->next;
703 } /* while */
704 logFunction(printf("exec_all_parameters -->\n"););
705 } /* exec_all_parameters */
706
707
708
exec_call(objectType object)709 objectType exec_call (objectType object)
710
711 {
712 objectType subroutine_object;
713 listType actual_parameters;
714 objectType result;
715
716 /* exec_call */
717 logFunction(printf("exec_call ");
718 trace1(object);
719 printf(" <-> ");
720 trace1(object->value.listValue->obj);
721 printf(" (");
722 prot_list(object->value.listValue->next);
723 printf(")\n"););
724 subroutine_object = object->value.listValue->obj;
725 actual_parameters = object->value.listValue->next;
726 /* if (CATEGORY_OF_OBJ(subroutine_object) == REFPARAMOBJECT) {
727 printf("refparamobject ");
728 trace1(subroutine_object);
729 printf(" value ");
730 trace1(subroutine_object->value.objValue);
731 printf(" params ");
732 prot_list(actual_parameters);
733 printf("\n");
734 printf("\n");
735 subroutine_object = subroutine_object->value.objValue;
736 } if */
737 switch (CATEGORY_OF_OBJ(subroutine_object)) {
738 case ACTOBJECT:
739 result = exec_action(subroutine_object,
740 actual_parameters, object);
741 break;
742 case BLOCKOBJECT:
743 /* printf("blockobject ");
744 trace1(subroutine_object);
745 printf(" params ");
746 prot_list(actual_parameters);
747 printf("\n"); */
748 result = exec_lambda(subroutine_object->value.blockValue,
749 actual_parameters, object);
750 break;
751 case CONSTENUMOBJECT:
752 /* printf("constenumobject ");
753 trace1(subroutine_object);
754 printf(" params ");
755 prot_list(actual_parameters);
756 printf("\n"); */
757 exec_all_parameters(actual_parameters);
758 result = subroutine_object->value.objValue;
759 break;
760 case INTOBJECT:
761 case BIGINTOBJECT:
762 case CHAROBJECT:
763 case STRIOBJECT:
764 case BSTRIOBJECT:
765 case ARRAYOBJECT:
766 case HASHOBJECT:
767 case STRUCTOBJECT:
768 case SETOBJECT:
769 case FILEOBJECT:
770 case SOCKETOBJECT:
771 case POLLOBJECT:
772 case LISTOBJECT:
773 #if WITH_FLOAT
774 case FLOATOBJECT:
775 #endif
776 case WINOBJECT:
777 case PROCESSOBJECT:
778 case VARENUMOBJECT:
779 case ENUMLITERALOBJECT:
780 case REFOBJECT:
781 case REFLISTOBJECT:
782 case TYPEOBJECT:
783 case INTERFACEOBJECT:
784 case PROGOBJECT:
785 case DATABASEOBJECT:
786 case SQLSTMTOBJECT:
787 case DECLAREDOBJECT:
788 /* printf("int/char/stri/array/file/type ");
789 trace1(subroutine_object);
790 printf(" params ");
791 prot_list(actual_parameters);
792 printf("\n"); */
793 exec_all_parameters(actual_parameters);
794 result = subroutine_object;
795 break;
796 case VALUEPARAMOBJECT:
797 case REFPARAMOBJECT:
798 case LOCALVOBJECT:
799 /* printf("refparamobject ");
800 trace1(subroutine_object);
801 printf(" value ");
802 trace1(subroutine_object->value.objValue);
803 printf(" params ");
804 prot_list(actual_parameters);
805 printf("\n");
806 printf("\n"); */
807 result = evaluate(subroutine_object->value.objValue);
808 /* result = exec_object(subroutine_object->value.objValue); */
809 break;
810 case MATCHOBJECT:
811 /* printf("\nsubroutine_object: ");
812 trace1(subroutine_object);
813 printf(" params ");
814 prot_list(actual_parameters);
815 printf("\n");
816 printf("\n"); */
817 result = evaluate(subroutine_object);
818 break;
819 case FORWARDOBJECT:
820 logError(printf("exec_call: forward object\n"););
821 result = raise_with_arguments(SYS_ACT_ILLEGAL_EXCEPTION, actual_parameters);
822 break;
823 default:
824 printf("category_of_obj: ");
825 trace1(object);
826 printf("\nsubroutine_object: ");
827 trace1(subroutine_object);
828 printf("\n");
829 printf("\n");
830 /* printf("%d\n", 1/0); */
831 /* result = exec_dynamic(object->value.listValue); */
832 result = NULL;
833 break;
834 } /* switch */
835 logFunction(printf("exec_call ");
836 trace1(result);
837 printf("\n"););
838 return result;
839 } /* exec_call */
840
841
842
getErrInfoFromFailValue(objectType failValue)843 static errInfoType getErrInfoFromFailValue (objectType failValue)
844
845 {
846 errInfoType err_info;
847
848 /* getErrInfoFromFailValue */
849 if (failValue == SYS_MEM_EXCEPTION) {
850 err_info = MEMORY_ERROR;
851 } else if (failValue == SYS_NUM_EXCEPTION) {
852 err_info = NUMERIC_ERROR;
853 } else if (failValue == SYS_OVF_EXCEPTION) {
854 err_info = OVERFLOW_ERROR;
855 } else if (failValue == SYS_RNG_EXCEPTION) {
856 err_info = RANGE_ERROR;
857 } else if (failValue == SYS_IDX_EXCEPTION) {
858 err_info = INDEX_ERROR;
859 } else if (failValue == SYS_FIL_EXCEPTION) {
860 err_info = FILE_ERROR;
861 } else if (failValue == SYS_DB_EXCEPTION) {
862 err_info = DATABASE_ERROR;
863 } else if (failValue == SYS_CLOSE_EXCEPTION) {
864 err_info = CLOSE_ERROR;
865 } else { /* if (failValue == SYS_ACT_ILLEGAL_EXCEPTION) { */
866 err_info = ACTION_ERROR;
867 } /* if */
868 return err_info;
869 } /* getErrInfoFromFailValue */
870
871
872
do_exec_call(objectType object,errInfoType * err_info)873 objectType do_exec_call (objectType object, errInfoType *err_info)
874
875 {
876 objectType result;
877
878 /* do_exec_call */
879 result = exec_call(object);
880 if (unlikely(fail_flag || result == NULL)) {
881 set_fail_flag(FALSE);
882 *err_info = getErrInfoFromFailValue(fail_value);
883 } /* if */
884 return result;
885 } /* do_exec_call */
886
887
888
889 /**
890 * Evaluate a call-by-name parameter.
891 * An actual call-by-name parameter is not evaluated before a function
892 * is called. Call-by-name parameters are used for the conditions of loops,
893 * the statements in loop bodies, the right parameter of the ternary
894 * operator, etc.
895 */
evaluate(objectType object)896 objectType evaluate (objectType object)
897
898 {
899 objectType result;
900
901 /* evaluate */
902 logFunction(printf("evaluate\n"););
903 #ifdef OUT_OF_ORDER
904 if (fail_flag) {
905 printf("evaluate fail_flag for ");
906 trace1(object);
907 printf("\n");
908 } /* if */
909 #endif
910 switch (CATEGORY_OF_OBJ(object)) {
911 case MATCHOBJECT:
912 result = exec_call(object);
913 break;
914 case VALUEPARAMOBJECT:
915 case REFPARAMOBJECT:
916 case RESULTOBJECT:
917 case CONSTENUMOBJECT:
918 case VARENUMOBJECT:
919 result = object->value.objValue;
920 break;
921 case INTOBJECT:
922 case BIGINTOBJECT:
923 case CHAROBJECT:
924 case STRIOBJECT:
925 case BSTRIOBJECT:
926 case ARRAYOBJECT:
927 case HASHOBJECT:
928 case STRUCTOBJECT:
929 case SETOBJECT:
930 case FILEOBJECT:
931 #if WITH_FLOAT
932 case FLOATOBJECT:
933 #endif
934 case WINOBJECT:
935 case REFOBJECT:
936 case REFLISTOBJECT:
937 case ENUMLITERALOBJECT:
938 result = object;
939 break;
940 case BLOCKOBJECT:
941 result = exec_lambda(object->value.blockValue, NULL, object);
942 break;
943 case ACTOBJECT:
944 result = exec_action(object, NULL, NULL);
945 break;
946 default:
947 logError(printf("evaluate: evaluate unknown\n");
948 trace1(object);
949 printf("\n"););
950 result = raise_with_arguments(SYS_ACT_ILLEGAL_EXCEPTION, NULL);
951 break;
952 } /* switch */
953 logFunction(printf("evaluate --> ");
954 trace1(result);
955 printf("\n"););
956 return result;
957 } /* evaluate */
958
959
960
eval_expression(objectType object)961 objectType eval_expression (objectType object)
962
963 {
964 objectType result;
965 objectType matched_expression;
966 objectType matched_object;
967
968 /* eval_expression */
969 logFunction(printf("eval_expression\n"););
970 if ((matched_expression = match_expression(object)) != NULL) {
971 if ((matched_object = match_object(matched_expression)) != NULL) {
972 /*
973 printf("eval expression match succeeded ");
974 trace1(matched_object);
975 printf("\n"); */
976 if (CATEGORY_OF_OBJ(matched_object) == CALLOBJECT) {
977 result = exec_call(matched_object);
978 } else {
979 printf("eval_expression: match result not callobject ");
980 trace1(matched_object);
981 printf("\n");
982 result = NULL;
983 } /* if */
984 } else {
985 printf("eval_expression: match object failed ");
986 trace1(matched_expression);
987 printf("\n");
988 result = NULL;
989 } /* if */
990 } else {
991 printf("eval_expression: match expression failed ");
992 trace1(object);
993 printf("\n");
994 result = NULL;
995 } /* if */
996 logFunction(printf("eval_expression -->\n"););
997 return result;
998 } /* eval_expression */
999
1000
1001
exec_dynamic(listType expr_list)1002 objectType exec_dynamic (listType expr_list)
1003
1004 {
1005 objectType dynamic_call_obj;
1006 objectType match_expr;
1007 listType actual_element;
1008 listType *list_insert_place;
1009 objectType element_value;
1010 objectType match_result;
1011 objectType result = NULL;
1012 errInfoType err_info = OKAY_NO_ERROR;
1013
1014 /* exec_dynamic */
1015 logFunction(printf("exec_dynamic\n"););
1016 #ifdef WITH_PROTOCOL
1017 if (trace.dynamic) {
1018 if (trace.heapsize) {
1019 prot_heapsize();
1020 prot_cstri(" ");
1021 } /* if */
1022 prot_cstri("DYNAMIC ");
1023 prot_list(expr_list);
1024 prot_nl();
1025 } /* if */
1026 #endif
1027 dynamic_call_obj = curr_exec_object;
1028 if (ALLOC_OBJECT(match_expr)) {
1029 match_expr->type_of = take_type(SYS_EXPR_TYPE);
1030 match_expr->descriptor.property = prog->property.literal;
1031 match_expr->value.listValue = NULL;
1032 list_insert_place = &match_expr->value.listValue;
1033 INIT_CATEGORY_OF_OBJ(match_expr, EXPROBJECT);
1034 actual_element = expr_list;
1035 while (actual_element != NULL) {
1036 /* printf("actual_element->obj ");
1037 trace1(actual_element->obj);
1038 printf("\n"); */
1039 switch (CATEGORY_OF_OBJ(actual_element->obj)) {
1040 case VALUEPARAMOBJECT:
1041 case REFPARAMOBJECT:
1042 case RESULTOBJECT:
1043 case LOCALVOBJECT:
1044 case CONSTENUMOBJECT:
1045 case VARENUMOBJECT:
1046 case INTERFACEOBJECT:
1047 element_value = actual_element->obj->value.objValue;
1048 break;
1049 default:
1050 element_value = actual_element->obj;
1051 break;
1052 } /* switch */
1053 /* printf("element_value ");
1054 trace1(element_value);
1055 printf("\n"); */
1056 #if !WITH_OBJECT_FREELIST
1057 /* If a freelist is used exec_action examines the */
1058 /* object on the freelist and will not free it, because */
1059 /* the TEMP flag is not set for free list objects. */
1060 if (TEMP_OBJECT(element_value)) {
1061 /* Exec_dynamic is called from the action PRC_DYNAMIC. */
1062 /* PRC_DYNAMIC is called from exec_action. Exec_action */
1063 /* frees temporary objects. To avoid double frees the */
1064 /* TEMP flag must be cleared here. */
1065 CLEAR_TEMP_FLAG(element_value);
1066 } /* if */
1067 #endif
1068 /* err_info is not checked after append! */
1069 list_insert_place = append_element_to_list(list_insert_place,
1070 element_value, &err_info);
1071 actual_element = actual_element->next;
1072 } /* while */
1073 #ifdef WITH_PROTOCOL
1074 if (trace.dynamic) {
1075 if (trace.heapsize) {
1076 prot_heapsize();
1077 prot_cstri(" ");
1078 } /* if */
1079 prot_cstri("DYNAMIC2 ");
1080 prot_list(match_expr->value.listValue);
1081 prot_nl();
1082 } /* if */
1083 #endif
1084 /* printf("match_expr ");
1085 trace1(match_expr);
1086 printf("\n"); */
1087 if (match_prog_expression(prog->declaration_root, match_expr) != NULL &&
1088 (match_result = match_object(match_expr)) != NULL) {
1089 #ifdef WITH_PROTOCOL
1090 if (trace.dynamic) {
1091 prot_cstri("matched ==> ");
1092 trace1(match_result);
1093 } /* if */
1094 #endif
1095 result = exec_call(match_result);
1096 if (fail_flag) {
1097 errInfoType ignored_err_info;
1098
1099 if (fail_stack->obj == match_result) {
1100 pop_list(&fail_stack);
1101 } /* if */
1102
1103 /* ignored_err_info is not checked since an exception was already raised */
1104 incl_list(&fail_stack, dynamic_call_obj, &ignored_err_info);
1105 } /* if */
1106
1107 if (match_result != match_expr) {
1108 FREE_OBJECT(match_result->value.listValue->obj);
1109 free_list(match_result->value.listValue);
1110 FREE_OBJECT(match_result);
1111 } else {
1112 free_list(match_expr->value.listValue);
1113 FREE_OBJECT(match_expr);
1114 } /* if */
1115 #ifdef WITH_PROTOCOL
1116 if (trace.dynamic) {
1117 if (trace.heapsize) {
1118 prot_cstri(" ");
1119 prot_heapsize();
1120 } /* if */
1121 prot_nl();
1122 } /* if */
1123 #endif
1124 } else {
1125 logError(printf("exec_dynamic: No match\n");
1126 trace1(match_expr);
1127 printf("\n"););
1128 return raise_with_arguments(SYS_ACT_ILLEGAL_EXCEPTION, expr_list);
1129 } /* if */
1130 } else {
1131 return raise_with_arguments(SYS_MEM_EXCEPTION, expr_list);
1132 } /* if */
1133 logFunction(printf("exec_dynamic -->\n"););
1134 return result;
1135 } /* exec_dynamic */
1136
1137
1138
exec_expr(const progType currentProg,objectType object,errInfoType * err_info)1139 objectType exec_expr (const progType currentProg, objectType object,
1140 errInfoType *err_info)
1141
1142 {
1143 progType progBackup;
1144 boolType backup_interpreter_exception;
1145 objectType result;
1146
1147 /* exec_expr */
1148 logFunction(printf("exec_expr\n"););
1149 if (currentProg != NULL) {
1150 set_fail_flag(FALSE);
1151 fail_value = NULL;
1152 fail_expression = NULL;
1153 progBackup = prog;
1154 prog = currentProg;
1155 set_protfile_name(NULL);
1156 prog->option_flags = 0;
1157 set_trace(prog->option_flags);
1158 backup_interpreter_exception = interpreter_exception;
1159 interpreter_exception = TRUE;
1160 result = exec_object(object);
1161 if (fail_flag) {
1162 /*
1163 printf("\n*** Uncaught EXCEPTION ");
1164 printobject(fail_value);
1165 printf(" raised with\n");
1166 prot_list(fail_expression);
1167 printf("\n");
1168 */
1169 *err_info = getErrInfoFromFailValue(fail_value);
1170 leaveExceptionHandling();
1171 } else {
1172 if (TEMP_OBJECT(result)) {
1173 CLEAR_TEMP_FLAG(result);
1174 incl_list(¤tProg->exec_expr_temp_results, result, err_info);
1175 } /* if */
1176 } /* if */
1177 interpreter_exception = backup_interpreter_exception;
1178 prog = progBackup;
1179 } else {
1180 result = NULL;
1181 } /* if */
1182 logFunction(printf("exec_expr --> ");
1183 trace1(result);
1184 printf("\n"););
1185 return result;
1186 } /* exec_expr */
1187