1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2021 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/prclib.c */
23 /* Changes: 1991 - 1994, 2007, 2009, 2010, 2012 Thomas Mertes */
24 /* 2013, 2015 - 2021 Thomas Mertes */
25 /* Content: Primitive actions to implement simple statements. */
26 /* */
27 /********************************************************************/
28
29 #define LOG_FUNCTIONS 0
30 #define VERBOSE_EXCEPTIONS 0
31
32 #include "version.h"
33
34 #include "stdlib.h"
35 #include "stdio.h"
36 #include "string.h"
37 #include "limits.h"
38
39 #include "common.h"
40 #include "sigutl.h"
41 #include "data.h"
42 #include "data_rtl.h"
43 #include "heaputl.h"
44 #include "flistutl.h"
45 #include "striutl.h"
46 #include "entutl.h"
47 #include "syvarutl.h"
48 #include "traceutl.h"
49 #include "typeutl.h"
50 #include "listutl.h"
51 #include "executl.h"
52 #include "objutl.h"
53 #include "findid.h"
54 #include "match.h"
55 #include "name.h"
56 #include "exec.h"
57 #include "runerr.h"
58 #include "blockutl.h"
59 #include "scanner.h"
60 #include "libpath.h"
61 #include "error.h"
62 #include "set_rtl.h"
63 #include "str_rtl.h"
64 #include "rtl_err.h"
65
66 #undef EXTERN
67 #define EXTERN
68 #include "prclib.h"
69
70
71
fix_posinfo(objectType block_body,const const_objectType block_body_list)72 static void fix_posinfo (objectType block_body, const const_objectType block_body_list)
73
74 { /* fix_posinfo */
75 if (block_body != NULL && block_body_list != NULL &&
76 CATEGORY_OF_OBJ(block_body) == CALLOBJECT &&
77 !HAS_POSINFO(block_body)) {
78 block_body->descriptor.posinfo = block_body_list->descriptor.posinfo;
79 SET_POSINFO_FLAG(block_body);
80 } /* if */
81 } /* fix_posinfo */
82
83
84
process_local_decl(objectType local_decl,listType * local_object_list,errInfoType * err_info)85 static objectType process_local_decl (objectType local_decl,
86 listType *local_object_list, errInfoType *err_info)
87
88 {
89 const_listType local_element;
90 objectType local_var;
91 objectType init_value;
92 objectType result;
93
94 /* process_local_decl */
95 logFunction(printf("process_local_decl(");
96 trace1(local_decl);
97 printf(", " FMT_X_MEM ")\n",
98 (memSizeType) local_object_list););
99 result = exec_call(local_decl);
100 if (result == SYS_EMPTY_OBJECT) {
101 local_element = *local_object_list;
102 while (local_element != NULL) {
103 if (VAR_OBJECT(local_element->obj)) {
104 local_var = local_element->obj;
105 if (CATEGORY_OF_OBJ(local_var) != LOCALVOBJECT) {
106 /* printf("U "); trace1(local_var); printf("\n"); */
107 if (likely(ALLOC_OBJECT(init_value))) {
108 init_value->type_of = local_var->type_of;
109 init_value->descriptor.property = NULL;
110 init_value->value = local_var->value;
111 init_value->objcategory = local_var->objcategory;
112 SET_CATEGORY_OF_OBJ(local_var, LOCALVOBJECT);
113 local_var->value.objValue = init_value; /* was NULL; changed for s7c.sd7 */
114 } else {
115 *err_info = MEMORY_ERROR;
116 } /* if */
117 } /* if */
118 } /* if */
119 local_element = local_element->next;
120 } /* while */
121 } /* if */
122 logFunction(printf("process_local_decl --> ");
123 trace1(result);
124 printf("\n"););
125 return result;
126 } /* process_local_decl */
127
128
129
evaluate_local_decls(objectType local_decls,listType * local_object_list,errInfoType * err_info)130 static objectType evaluate_local_decls (objectType local_decls,
131 listType *local_object_list, errInfoType *err_info)
132
133 {
134 listType semicol_params;
135 boolType finished = FALSE;
136 objectType result;
137
138 /* evaluate_local_decls */
139 logFunction(printf("evaluate_local_decls(");
140 trace1(local_decls);
141 printf(", " FMT_X_MEM ")\n",
142 (memSizeType) local_object_list););
143 do {
144 if (CATEGORY_OF_OBJ(local_decls) == MATCHOBJECT ||
145 CATEGORY_OF_OBJ(local_decls) == CALLOBJECT) {
146 semicol_params = local_decls->value.listValue;
147 if (list_length(semicol_params) == 4 &&
148 CATEGORY_OF_OBJ(arg_1(semicol_params)) == ACTOBJECT &&
149 take_action(arg_1(semicol_params)) == &prc_noop) {
150 result = process_local_decl(arg_2(semicol_params),
151 local_object_list, err_info);
152 local_decls = arg_4(semicol_params);
153 } else {
154 result = process_local_decl(local_decls,
155 local_object_list, err_info);
156 finished = TRUE;
157 } /* if */
158 } else {
159 result = process_local_decl(local_decls,
160 local_object_list, err_info);
161 finished = TRUE;
162 } /* if */
163 } while (!finished && result == SYS_EMPTY_OBJECT);
164 logFunction(printf("evaluate_local_decls --> ");
165 trace1(result);
166 printf("\n"););
167 return result;
168 } /* evaluate_local_decls */
169
170
171
172 /**
173 * Return the argument vector of the program as array of strings.
174 * The name of the program is not part of the argument vector.
175 * @return an array of strings containing the argument vector.
176 */
prc_args(listType arguments)177 objectType prc_args (listType arguments)
178
179 { /* prc_args */
180 return prog->arg_v;
181 } /* prc_args */
182
183
184
prc_begin(listType arguments)185 objectType prc_begin (listType arguments)
186
187 {
188 objectType block_body;
189 objectType block_body_list = NULL;
190 errInfoType err_info = OKAY_NO_ERROR;
191 blockType block;
192
193 /* prc_begin */
194 logFunction(printf("prc_begin\n"););
195 block_body = arg_3(arguments);
196 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
197 block_body->value.listValue != NULL &&
198 block_body->value.listValue->next == NULL) {
199 block_body_list = block_body;
200 block_body = block_body->value.listValue->obj;
201 } /* if */
202 block_body = copy_expression(block_body, &err_info);
203 if (err_info == OKAY_NO_ERROR) {
204 push_stack();
205 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
206 update_owner(block_body);
207 block_body = match_expression(block_body);
208 } /* if */
209 if (block_body != NULL) {
210 block_body = match_object(block_body);
211 fix_posinfo(block_body, block_body_list);
212 } /* if */
213 pop_stack();
214 if (block_body != NULL && block_body->type_of != take_type(SYS_PROC_TYPE)) {
215 err_type(PROC_EXPECTED, block_body->type_of);
216 } /* if */
217 } /* if */
218 if (unlikely(err_info != OKAY_NO_ERROR ||
219 block_body == NULL ||
220 (block = new_block(NULL, NULL, NULL, NULL, block_body)) == NULL)) {
221 logError(printf("prc_begin: No memory\n"););
222 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
223 } else {
224 logFunction(printf("prc_begin -->\n"););
225 return bld_block_temp(block);
226 } /* if */
227 } /* prc_begin */
228
229
230
prc_block(listType arguments)231 objectType prc_block (listType arguments)
232
233 {
234 objectType statement;
235 objectType current_catch;
236 objectType catch_value;
237 objectType catch_statement;
238 boolType searching;
239
240 /* prc_block */
241 statement = arg_2(arguments);
242 evaluate(statement);
243 if (unlikely(fail_flag)) {
244 searching = TRUE;
245 current_catch = arg_4(arguments);
246 while (current_catch != NULL && searching &&
247 CATEGORY_OF_OBJ(current_catch) == MATCHOBJECT &&
248 current_catch->value.listValue->next->next->next->next != NULL) {
249 catch_value = arg_3(current_catch->value.listValue);
250 if (catch_value == fail_value) {
251 catch_statement = arg_5(current_catch->value.listValue);
252 leaveExceptionHandling();
253 evaluate(catch_statement);
254 searching = FALSE;
255 } else {
256 if (current_catch->value.listValue->next->next->next->next->next != NULL) {
257 current_catch = arg_6(current_catch->value.listValue);
258 } else {
259 current_catch = NULL;
260 } /* if */
261 } /* if */
262 } /* while */
263 } /* if */
264 return SYS_EMPTY_OBJECT;
265 } /* prc_block */
266
267
268
prc_block_catch_all(listType arguments)269 objectType prc_block_catch_all (listType arguments)
270
271 {
272 objectType statement;
273 objectType default_statement;
274
275 /* prc_block_catch_all */
276 statement = arg_2(arguments);
277 evaluate(statement);
278 if (unlikely(fail_flag)) {
279 default_statement = arg_6(arguments);
280 leaveExceptionHandling();
281 evaluate(default_statement);
282 } /* if */
283 return SYS_EMPTY_OBJECT;
284 } /* prc_block_catch_all */
285
286
287
prc_block_otherwise(listType arguments)288 objectType prc_block_otherwise (listType arguments)
289
290 {
291 objectType statement;
292 objectType otherwise_statement;
293 objectType current_catch;
294 objectType catch_value;
295 objectType catch_statement;
296 boolType searching;
297
298 /* prc_block_otherwise */
299 statement = arg_2(arguments);
300 evaluate(statement);
301 if (unlikely(fail_flag)) {
302 searching = TRUE;
303 current_catch = arg_4(arguments);
304 while (current_catch != NULL && searching &&
305 CATEGORY_OF_OBJ(current_catch) == MATCHOBJECT &&
306 current_catch->value.listValue->next->next->next->next != NULL) {
307 catch_value = arg_3(current_catch->value.listValue);
308 if (catch_value == fail_value) {
309 catch_statement = arg_5(current_catch->value.listValue);
310 leaveExceptionHandling();
311 evaluate(catch_statement);
312 searching = FALSE;
313 } else {
314 if (current_catch->value.listValue->next->next->next->next->next != NULL) {
315 current_catch = arg_6(current_catch->value.listValue);
316 } else {
317 current_catch = NULL;
318 } /* if */
319 } /* if */
320 } /* while */
321 if (searching) {
322 otherwise_statement = arg_7(arguments);
323 leaveExceptionHandling();
324 evaluate(otherwise_statement);
325 } /* if */
326 } /* if */
327 return SYS_EMPTY_OBJECT;
328 } /* prc_block_otherwise */
329
330
331
prc_case(listType arguments)332 objectType prc_case (listType arguments)
333
334 {
335 objectType switch_object;
336 intType switch_value;
337 objectType when_objects;
338 objectType current_when;
339 objectType when_values;
340 objectType when_set;
341 setType set_value;
342 objectType when_statement = NULL;
343 errInfoType err_info = OKAY_NO_ERROR;
344 listType err_arguments;
345
346 /* prc_case */
347 logFunction(printf("prc_case\n"););
348 switch_object = arg_2(arguments);
349 when_objects = arg_4(arguments);
350 current_when = when_objects;
351 err_arguments = arguments;
352 switch_value = do_ord(switch_object, &err_info);
353 while (err_info == OKAY_NO_ERROR && current_when != NULL &&
354 CATEGORY_OF_OBJ(current_when) == MATCHOBJECT &&
355 current_when->value.listValue->next->next->next->next != NULL) {
356 when_values = arg_3(current_when->value.listValue);
357 if (CATEGORY_OF_OBJ(when_values) != SETOBJECT) {
358 when_set = exec_object(when_values);
359 isit_not_null(when_set);
360 isit_set(when_set);
361 set_value = take_set(when_set);
362 if (TEMP_OBJECT(when_set)) {
363 when_values->type_of = NULL;
364 when_values->descriptor.property = NULL;
365 SET_CATEGORY_OF_OBJ(when_values, SETOBJECT);
366 when_values->value.setValue = set_value;
367 current_when->value.listValue->next->next->obj = when_values;
368 } /* if */
369 } else {
370 set_value = take_set(when_values);
371 } /* if */
372 if (setElem(switch_value, set_value)) {
373 if (unlikely(when_statement != NULL)) {
374 logError(printf("prc_case(" FMT_D "): "
375 FMT_D " is in more then one \"when\" set.\n",
376 switch_value, switch_value););
377 err_info = ACTION_ERROR;
378 err_arguments = current_when->value.listValue->next;
379 } else {
380 when_statement = arg_5(current_when->value.listValue);
381 } /* if */
382 } /* if */
383 if (current_when->value.listValue->next->next->next->next->next != NULL) {
384 current_when = arg_6(current_when->value.listValue);
385 } else {
386 current_when = NULL;
387 } /* if */
388 } /* while */
389 if (unlikely(err_info != OKAY_NO_ERROR)) {
390 return raise_with_arguments(prog->sys_var[err_info], err_arguments);
391 } else if (when_statement != NULL) {
392 evaluate(when_statement);
393 } /* if */
394 logFunction(printf("prc_case -->\n"););
395 return SYS_EMPTY_OBJECT;
396 } /* prc_case */
397
398
399
prc_case_def(listType arguments)400 objectType prc_case_def (listType arguments)
401
402 {
403 objectType switch_object;
404 intType switch_value;
405 objectType when_objects;
406 objectType default_statement;
407 objectType current_when;
408 objectType when_values;
409 objectType when_set;
410 setType set_value;
411 objectType when_statement = NULL;
412 errInfoType err_info = OKAY_NO_ERROR;
413 listType err_arguments;
414
415 /* prc_case_def */
416 logFunction(printf("prc_case_def\n"););
417 switch_object = arg_2(arguments);
418 when_objects = arg_4(arguments);
419 current_when = when_objects;
420 err_arguments = arguments;
421 switch_value = do_ord(switch_object, &err_info);
422 while (err_info == OKAY_NO_ERROR && current_when != NULL &&
423 CATEGORY_OF_OBJ(current_when) == MATCHOBJECT &&
424 current_when->value.listValue->next->next->next->next != NULL) {
425 when_values = arg_3(current_when->value.listValue);
426 if (CATEGORY_OF_OBJ(when_values) != SETOBJECT) {
427 when_set = exec_object(when_values);
428 isit_not_null(when_set);
429 isit_set(when_set);
430 set_value = take_set(when_set);
431 if (TEMP_OBJECT(when_set)) {
432 when_values->type_of = NULL;
433 when_values->descriptor.property = NULL;
434 SET_CATEGORY_OF_OBJ(when_values, SETOBJECT);
435 when_values->value.setValue = set_value;
436 current_when->value.listValue->next->next->obj = when_values;
437 } /* if */
438 } else {
439 set_value = take_set(when_values);
440 } /* if */
441 if (setElem(switch_value, set_value)) {
442 if (unlikely(when_statement != NULL)) {
443 logError(printf("prc_case_def(" FMT_D "): "
444 FMT_D " is in more then one \"when\" set.\n",
445 switch_value, switch_value););
446 err_info = ACTION_ERROR;
447 err_arguments = current_when->value.listValue->next;
448 } else {
449 when_statement = arg_5(current_when->value.listValue);
450 } /* if */
451 } /* if */
452 if (current_when->value.listValue->next->next->next->next->next != NULL) {
453 current_when = arg_6(current_when->value.listValue);
454 } else {
455 current_when = NULL;
456 } /* if */
457 } /* while */
458 if (unlikely(err_info != OKAY_NO_ERROR)) {
459 return raise_with_arguments(prog->sys_var[err_info], err_arguments);
460 } else if (when_statement != NULL) {
461 evaluate(when_statement);
462 } else {
463 default_statement = arg_7(arguments);
464 evaluate(default_statement);
465 } /* if */
466 logFunction(printf("prc_case_def -->\n"););
467 return SYS_EMPTY_OBJECT;
468 } /* prc_case_def */
469
470
471
prc_case_hashset(listType arguments)472 objectType prc_case_hashset (listType arguments)
473
474 {
475 objectType switch_object;
476 objectType when_objects;
477 objectType current_when;
478 objectType when_values;
479 objectType when_set;
480 hashType hashMap_value;
481 objectType when_statement = NULL;
482 errInfoType err_info = OKAY_NO_ERROR;
483 listType err_arguments;
484
485 /* prc_case_hashset */
486 logFunction(printf("prc_case_hashset\n"););
487 switch_object = arg_2(arguments);
488 when_objects = arg_4(arguments);
489 current_when = when_objects;
490 err_arguments = arguments;
491 while (err_info == OKAY_NO_ERROR && current_when != NULL &&
492 CATEGORY_OF_OBJ(current_when) == MATCHOBJECT &&
493 current_when->value.listValue->next->next->next->next != NULL) {
494 when_values = arg_3(current_when->value.listValue);
495 if (CATEGORY_OF_OBJ(when_values) != HASHOBJECT) {
496 when_set = exec_object(when_values);
497 isit_not_null(when_set);
498 isit_hash(when_set);
499 hashMap_value = take_hash(when_set);
500 if (TEMP_OBJECT(when_set)) {
501 when_values->type_of = when_set->type_of;
502 when_values->descriptor.property = NULL;
503 SET_CATEGORY_OF_OBJ(when_values, HASHOBJECT);
504 when_values->value.hashValue = hashMap_value;
505 } /* if */
506 } /* if */
507 if (do_in(switch_object, when_values, &err_info)) {
508 if (unlikely(when_statement != NULL)) {
509 logError(printf("prc_case_hashset: "
510 "Switch value in more then one \"when\" set.\n"););
511 err_info = ACTION_ERROR;
512 err_arguments = current_when->value.listValue->next;
513 } else {
514 when_statement = arg_5(current_when->value.listValue);
515 } /* if */
516 } /* if */
517 if (current_when->value.listValue->next->next->next->next->next != NULL) {
518 current_when = arg_6(current_when->value.listValue);
519 } else {
520 current_when = NULL;
521 } /* if */
522 } /* while */
523 if (unlikely(err_info != OKAY_NO_ERROR)) {
524 return raise_with_arguments(prog->sys_var[err_info], err_arguments);
525 } else if (when_statement != NULL) {
526 evaluate(when_statement);
527 } /* if */
528 logFunction(printf("prc_case_hashset -->\n"););
529 return SYS_EMPTY_OBJECT;
530 } /* prc_case_hashset */
531
532
533
prc_case_hashset_def(listType arguments)534 objectType prc_case_hashset_def (listType arguments)
535
536 {
537 objectType switch_object;
538 objectType when_objects;
539 objectType default_statement;
540 objectType current_when;
541 objectType when_values;
542 objectType when_set;
543 hashType hashMap_value;
544 objectType when_statement = NULL;
545 errInfoType err_info = OKAY_NO_ERROR;
546 listType err_arguments;
547
548 /* prc_case_hashset_def */
549 logFunction(printf("prc_case_hashset_def\n"););
550 switch_object = arg_2(arguments);
551 when_objects = arg_4(arguments);
552 current_when = when_objects;
553 err_arguments = arguments;
554 while (err_info == OKAY_NO_ERROR && current_when != NULL &&
555 CATEGORY_OF_OBJ(current_when) == MATCHOBJECT &&
556 current_when->value.listValue->next->next->next->next != NULL) {
557 when_values = arg_3(current_when->value.listValue);
558 if (CATEGORY_OF_OBJ(when_values) != HASHOBJECT) {
559 when_set = exec_object(when_values);
560 isit_not_null(when_set);
561 isit_hash(when_set);
562 hashMap_value = take_hash(when_set);
563 if (TEMP_OBJECT(when_set)) {
564 when_values->type_of = when_set->type_of;
565 when_values->descriptor.property = NULL;
566 SET_CATEGORY_OF_OBJ(when_values, HASHOBJECT);
567 when_values->value.hashValue = hashMap_value;
568 } /* if */
569 } /* if */
570 if (do_in(switch_object, when_values, &err_info)) {
571 if (unlikely(when_statement != NULL)) {
572 logError(printf("prc_case_hashset_def: "
573 "Switch value in more then one \"when\" set.\n"););
574 err_info = ACTION_ERROR;
575 err_arguments = current_when->value.listValue->next;
576 } else {
577 when_statement = arg_5(current_when->value.listValue);
578 } /* if */
579 } /* if */
580 if (current_when->value.listValue->next->next->next->next->next != NULL) {
581 current_when = arg_6(current_when->value.listValue);
582 } else {
583 current_when = NULL;
584 } /* if */
585 } /* while */
586 if (unlikely(err_info != OKAY_NO_ERROR)) {
587 return raise_with_arguments(prog->sys_var[err_info], err_arguments);
588 } else if (when_statement != NULL) {
589 evaluate(when_statement);
590 } else {
591 default_statement = arg_7(arguments);
592 evaluate(default_statement);
593 } /* if */
594 logFunction(printf("prc_case_hashset_def -->\n"););
595 return SYS_EMPTY_OBJECT;
596 } /* prc_case_hashset_def */
597
598
599
600 /**
601 * Assign source/arg_3 to dest/arg_1.
602 * A copy function assumes that dest/arg_1 contains a legal value.
603 */
prc_cpy(listType arguments)604 objectType prc_cpy (listType arguments)
605
606 {
607 objectType dest;
608 objectType source;
609 objectType block_value;
610 errInfoType err_info = OKAY_NO_ERROR;
611
612 /* prc_cpy */
613 dest = arg_1(arguments);
614 isit_proc(dest);
615 /* is_variable(dest); */
616 isit_proc(arg_3(arguments));
617 source = arg_3(arguments);
618 /* printf("\nprc_cpy src (" FMT_U_MEM "): ", (memSizeType) source);
619 trace1(source);
620 printf("\n");
621 printf("prc_cpy dst (" FMT_U_MEM "): ", (memSizeType) dest);
622 trace1(dest);
623 printf("\n"); */
624 if (CATEGORY_OF_OBJ(dest) == MATCHOBJECT) {
625 if (unlikely(dest->value.listValue->next != 0)) {
626 return raise_exception(SYS_ACT_ILLEGAL_EXCEPTION);
627 } else {
628 dest = dest->value.listValue->obj;
629 } /* if */
630 } /* if */
631 is_variable(dest);
632 if (CATEGORY_OF_OBJ(source) == BLOCKOBJECT) {
633 if (likely(ALLOC_OBJECT(block_value))) {
634 memcpy(block_value, source, sizeof(objectRecord));
635 SET_CATEGORY_OF_OBJ(dest, MATCHOBJECT);
636 dest->value.listValue = NULL;
637 incl_list(&dest->value.listValue, block_value, &err_info);
638 if (TEMP_OBJECT(source)) {
639 source->value.blockValue = NULL;
640 } /* if */
641 } else {
642 return raise_exception(SYS_MEM_EXCEPTION);
643 } /* if */
644 } else {
645 SET_CATEGORY_OF_OBJ(dest, CATEGORY_OF_OBJ(source));
646 dest->value = source->value;
647 } /* if */
648 /* printf("prc_cpy dst (" FMT_U_MEM "): ", (memSizeType) dest);
649 trace1(dest);
650 printf("\n"); */
651 return SYS_EMPTY_OBJECT;
652 } /* prc_cpy */
653
654
655
656 /**
657 * Initialize dest/arg_1 and assign source/arg_3 to it.
658 * A create function assumes that the contents of dest/arg_1
659 * is undefined. Create functions can be used to initialize
660 * constants.
661 */
prc_create(listType arguments)662 objectType prc_create (listType arguments)
663
664 {
665 objectType dest;
666 objectType source;
667
668 /* prc_create */
669 dest = arg_1(arguments);
670 source = arg_3(arguments);
671 /* printf("\nprc_create src (" FMT_U_MEM "): ", (memSizeType) source);
672 trace1(source);
673 printf("\n"); */
674 isit_proc(source);
675 SET_CATEGORY_OF_OBJ(dest, CATEGORY_OF_OBJ(source));
676 dest->value = source->value;
677 if (TEMP_OBJECT(source)) {
678 source->value.blockValue = NULL;
679 } /* if */
680 /* printf("prc_create dst (" FMT_U_MEM "): ", (memSizeType) dest);
681 trace1(dest);
682 printf("\n"); */
683 return SYS_EMPTY_OBJECT;
684 } /* prc_create */
685
686
687
prc_decls(listType arguments)688 objectType prc_decls (listType arguments)
689
690 { /* prc_decls */
691 trace_nodes();
692 return SYS_EMPTY_OBJECT;
693 } /* prc_decls */
694
695
696
prc_dynamic(listType arguments)697 objectType prc_dynamic (listType arguments)
698
699 {
700 objectType result;
701
702 /* prc_dynamic */
703 result = exec_dynamic(arguments);
704 return result;
705 } /* prc_dynamic */
706
707
708
prc_exit(listType arguments)709 objectType prc_exit (listType arguments)
710
711 {
712 intType status;
713
714 /* prc_exit */
715 isit_int(arg_1(arguments));
716 status = take_int(arg_1(arguments));
717 if (!inIntRange(status)) {
718 logError(printf("prc_exit(" FMT_D "): "
719 "Exit status not in allowed range (%d .. %d).\n",
720 status, INT_MIN, INT_MAX););
721 raise_error(RANGE_ERROR);
722 } else {
723 shutDrivers();
724 exit((int) status);
725 } /* if */
726 return SYS_EMPTY_OBJECT;
727 } /* prc_exit */
728
729
730
prc_for_downto(listType arguments)731 objectType prc_for_downto (listType arguments)
732
733 {
734 objectType for_variable;
735 intType upper_limit;
736 intType lower_limit;
737 objectType statement;
738
739 /* prc_for_downto */
740 for_variable = arg_2(arguments);
741 is_variable(for_variable);
742 isit_int(for_variable);
743 isit_int(arg_4(arguments));
744 isit_int(arg_6(arguments));
745 upper_limit = take_int(arg_4(arguments));
746 lower_limit = take_int(arg_6(arguments));
747 statement = arg_8(arguments);
748 if (unlikely(lower_limit == INTTYPE_MIN)) {
749 logError(printf("prc_for_downto(var1, " FMT_D ", " FMT_D "): "
750 "Lower limit of integer.first not allowed.\n",
751 upper_limit, lower_limit););
752 return raise_exception(SYS_RNG_EXCEPTION);
753 } else {
754 for_variable->value.intValue = upper_limit;
755 while (take_int(for_variable) >= lower_limit && !fail_flag) {
756 evaluate(statement);
757 if (!fail_flag) {
758 for_variable->value.intValue--;
759 } /* if */
760 } /* while */
761 } /* if */
762 return SYS_EMPTY_OBJECT;
763 } /* prc_for_downto */
764
765
766
prc_for_downto_step(listType arguments)767 objectType prc_for_downto_step (listType arguments)
768
769 {
770 objectType for_variable;
771 intType upper_limit;
772 intType lower_limit;
773 intType incr_step;
774 objectType statement;
775
776 /* prc_for_downto_step */
777 for_variable = arg_2(arguments);
778 is_variable(for_variable);
779 isit_int(for_variable);
780 isit_int(arg_4(arguments));
781 isit_int(arg_6(arguments));
782 isit_int(arg_8(arguments));
783 upper_limit = take_int(arg_4(arguments));
784 lower_limit = take_int(arg_6(arguments));
785 incr_step = take_int(arg_8(arguments));
786 statement = arg_10(arguments);
787 for_variable->value.intValue = upper_limit;
788 while (take_int(for_variable) >= lower_limit && !fail_flag) {
789 evaluate(statement);
790 if (!fail_flag) {
791 for_variable->value.intValue -= incr_step;
792 } /* if */
793 } /* while */
794 return SYS_EMPTY_OBJECT;
795 } /* prc_for_downto_step */
796
797
798
prc_for_to(listType arguments)799 objectType prc_for_to (listType arguments)
800
801 {
802 objectType for_variable;
803 intType lower_limit;
804 intType upper_limit;
805 objectType statement;
806
807 /* prc_for_to */
808 for_variable = arg_2(arguments);
809 is_variable(for_variable);
810 isit_int(for_variable);
811 isit_int(arg_4(arguments));
812 isit_int(arg_6(arguments));
813 lower_limit = take_int(arg_4(arguments));
814 upper_limit = take_int(arg_6(arguments));
815 statement = arg_8(arguments);
816 if (unlikely(upper_limit == INTTYPE_MAX)) {
817 logError(printf("prc_for_to(var1, " FMT_D ", " FMT_D "): "
818 "Upper limit of integer.last not allowed.\n",
819 lower_limit, upper_limit););
820 return raise_exception(SYS_RNG_EXCEPTION);
821 } else {
822 for_variable->value.intValue = lower_limit;
823 while (take_int(for_variable) <= upper_limit && !fail_flag) {
824 evaluate(statement);
825 if (!fail_flag) {
826 for_variable->value.intValue++;
827 } /* if */
828 } /* while */
829 } /* if */
830 return SYS_EMPTY_OBJECT;
831 } /* prc_for_to */
832
833
834
prc_for_to_step(listType arguments)835 objectType prc_for_to_step (listType arguments)
836
837 {
838 objectType for_variable;
839 intType lower_limit;
840 intType upper_limit;
841 intType incr_step;
842 objectType statement;
843
844 /* prc_for_to_step */
845 for_variable = arg_2(arguments);
846 is_variable(for_variable);
847 isit_int(for_variable);
848 isit_int(arg_4(arguments));
849 isit_int(arg_6(arguments));
850 isit_int(arg_8(arguments));
851 lower_limit = take_int(arg_4(arguments));
852 upper_limit = take_int(arg_6(arguments));
853 incr_step = take_int(arg_8(arguments));
854 statement = arg_10(arguments);
855 for_variable->value.intValue = lower_limit;
856 while (take_int(for_variable) <= upper_limit && !fail_flag) {
857 evaluate(statement);
858 if (!fail_flag) {
859 for_variable->value.intValue += incr_step;
860 } /* if */
861 } /* while */
862 return SYS_EMPTY_OBJECT;
863 } /* prc_for_to_step */
864
865
866
prc_heapstat(listType arguments)867 objectType prc_heapstat (listType arguments)
868
869 { /* prc_heapstat */
870 heapStatistic();
871 return SYS_EMPTY_OBJECT;
872 } /* prc_heapstat */
873
874
875
prc_hsize(listType arguments)876 objectType prc_hsize (listType arguments)
877
878 { /* prc_hsize */
879 /* heapStatistic(); */
880 return bld_int_temp((intType) heapsize());
881 } /* prc_hsize */
882
883
884
prc_if(listType arguments)885 objectType prc_if (listType arguments)
886
887 {
888 objectType condition;
889
890 /* prc_if */
891 isit_bool(arg_2(arguments));
892 condition = take_bool(arg_2(arguments));
893 if (condition == SYS_TRUE_OBJECT) {
894 evaluate(arg_4(arguments));
895 } /* if */
896 return SYS_EMPTY_OBJECT;
897 } /* prc_if */
898
899
900
prc_if_elsif(listType arguments)901 objectType prc_if_elsif (listType arguments)
902
903 {
904 objectType condition;
905
906 /* prc_if_elsif */
907 isit_bool(arg_2(arguments));
908 condition = take_bool(arg_2(arguments));
909 if (condition == SYS_TRUE_OBJECT) {
910 evaluate(arg_4(arguments));
911 } else {
912 evaluate(arg_5(arguments));
913 } /* if */
914 return SYS_EMPTY_OBJECT;
915 } /* prc_if_elsif */
916
917
918
prc_if_noop(listType arguments)919 objectType prc_if_noop (listType arguments)
920
921 {
922 objectType condition;
923
924 /* prc_if_noop */
925 isit_bool(arg_2(arguments));
926 condition = take_bool(arg_2(arguments));
927 if (condition != SYS_TRUE_OBJECT) {
928 evaluate(arg_4(arguments));
929 } /* if */
930 return SYS_EMPTY_OBJECT;
931 } /* prc_if_noop */
932
933
934
prc_include(listType arguments)935 objectType prc_include (listType arguments)
936
937 {
938 striType includeFileName;
939 includeResultType includeResult;
940 errInfoType err_info = OKAY_NO_ERROR;
941
942 /* prc_include */
943 isit_stri(arg_2(arguments));
944 includeFileName = take_stri(arg_2(arguments));
945 logFunction(printf("prc_include(\"%s\")\n",
946 striAsUnquotedCStri(includeFileName)));
947 if (strChPos(includeFileName, (charType) '\\') != 0) {
948 err_stri(WRONG_PATH_DELIMITER, includeFileName);
949 } else {
950 includeResult = findIncludeFile((rtlHashType) prog->includeFileHash,
951 includeFileName, &err_info);
952 if (unlikely(includeResult == INCLUDE_FAILED)) {
953 if (err_info == ACTION_ERROR) {
954 /* This is a compile-time function and it is called at run-time. */
955 return raise_with_arguments(SYS_ACT_ILLEGAL_EXCEPTION, arguments);
956 } else if (err_info == MEMORY_ERROR) {
957 err_warning(OUT_OF_HEAP_SPACE);
958 } else {
959 /* FILE_ERROR or RANGE_ERROR */
960 err_stri(FILENOTFOUND, includeFileName);
961 } /* if */
962 } else if (includeResult == INCLUDE_SUCCESS) {
963 scan_byte_order_mark();
964 scan_symbol();
965 } /* if */
966 } /* if */
967 logFunction(printf("prc_include -->\n"););
968 return SYS_EMPTY_OBJECT;
969 } /* prc_include */
970
971
972
prc_local(listType arguments)973 objectType prc_local (listType arguments)
974
975 {
976 objectType local_decls;
977 objectType block_body;
978 objectType block_body_list = NULL;
979 listType *local_object_insert_place;
980 locListType local_vars;
981 listType local_consts;
982 objectType decl_res;
983 errInfoType err_info = OKAY_NO_ERROR;
984 blockType block;
985
986 /* prc_local */
987 logFunction(printf("prc_local\n"););
988 local_decls = arg_3(arguments);
989 block_body = arg_5(arguments);
990 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
991 block_body->value.listValue != NULL &&
992 block_body->value.listValue->next == NULL) {
993 block_body_list = block_body;
994 block_body = block_body->value.listValue->obj;
995 } /* if */
996 block_body = copy_expression(block_body, &err_info);
997 if (err_info == OKAY_NO_ERROR) {
998 push_stack();
999 local_object_insert_place = get_local_object_insert_place();
1000 decl_res = evaluate_local_decls(local_decls, local_object_insert_place, &err_info);
1001 if (decl_res != SYS_EMPTY_OBJECT) {
1002 /* printf("eval local decls --> ");
1003 trace1(decl_res);
1004 printf("\n");
1005 trace1(SYS_EMPTY_OBJECT);
1006 printf("\n"); */
1007 err_object(PROC_EXPECTED, decl_res);
1008 } /* if */
1009 local_vars = get_local_var_list(*local_object_insert_place, &err_info);
1010 local_consts = get_local_const_list(*local_object_insert_place, &err_info);
1011 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1012 update_owner(block_body);
1013 block_body = match_expression(block_body);
1014 } /* if */
1015 if (block_body != NULL) {
1016 block_body = match_object(block_body);
1017 fix_posinfo(block_body, block_body_list);
1018 } /* if */
1019 pop_stack();
1020 if (block_body != NULL && block_body->type_of != take_type(SYS_PROC_TYPE)) {
1021 err_type(PROC_EXPECTED, block_body->type_of);
1022 } /* if */
1023 } /* if */
1024 if (unlikely(err_info != OKAY_NO_ERROR ||
1025 block_body == NULL ||
1026 (block = new_block(NULL, NULL, local_vars, local_consts, block_body)) == NULL)) {
1027 logError(printf("prc_local: No memory\n"););
1028 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1029 } else {
1030 logFunction(printf("prc_local -->\n"););
1031 return bld_block_temp(block);
1032 } /* if */
1033 } /* prc_local */
1034
1035
1036
prc_noop(listType arguments)1037 objectType prc_noop (listType arguments)
1038
1039 { /* prc_noop */
1040 return SYS_EMPTY_OBJECT;
1041 } /* prc_noop */
1042
1043
1044
prc_raise(listType arguments)1045 objectType prc_raise (listType arguments)
1046
1047 { /* prc_raise */
1048 isit_enum(arg_2(arguments));
1049 return raise_exception(take_enum(arg_2(arguments)));
1050 } /* prc_raise */
1051
1052
1053
prc_repeat(listType arguments)1054 objectType prc_repeat (listType arguments)
1055
1056 {
1057 objectType statement;
1058 objectType condition;
1059 objectType cond_value;
1060 boolType cond;
1061
1062 /* prc_repeat */
1063 statement = arg_2(arguments);
1064 condition = arg_4(arguments);
1065 do {
1066 evaluate(statement);
1067 if (likely(!fail_flag)) {
1068 cond_value = evaluate(condition);
1069 if (likely(!fail_flag)) {
1070 isit_bool(cond_value);
1071 cond = (boolType) (take_bool(cond_value) == SYS_FALSE_OBJECT);
1072 if (TEMP_OBJECT(cond_value)) {
1073 dump_any_temp(cond_value);
1074 } /* if */
1075 } /* if */
1076 } /* if */
1077 } while (!fail_flag && cond);
1078 return SYS_EMPTY_OBJECT;
1079 } /* prc_repeat */
1080
1081
1082
prc_repeat_noop(listType arguments)1083 objectType prc_repeat_noop (listType arguments)
1084
1085 {
1086 objectType condition;
1087 objectType cond_value;
1088 boolType cond;
1089
1090 /* prc_repeat_noop */
1091 condition = arg_3(arguments);
1092 do {
1093 cond_value = evaluate(condition);
1094 if (likely(!fail_flag)) {
1095 isit_bool(cond_value);
1096 cond = (boolType) (take_bool(cond_value) == SYS_FALSE_OBJECT);
1097 if (TEMP_OBJECT(cond_value)) {
1098 dump_any_temp(cond_value);
1099 } /* if */
1100 } /* if */
1101 } while (!fail_flag && cond);
1102 return SYS_EMPTY_OBJECT;
1103 } /* prc_repeat_noop */
1104
1105
1106
prc_res_begin(listType arguments)1107 objectType prc_res_begin (listType arguments)
1108
1109 {
1110 typeType result_type;
1111 objectType result_var_name;
1112 locObjRecord result_var;
1113 objectType result_init;
1114 objectType block_body;
1115 objectType block_body_list = NULL;
1116 errInfoType err_info = OKAY_NO_ERROR;
1117 blockType block;
1118
1119 /* prc_res_begin */
1120 logFunction(printf("prc_res_begin\n"););
1121 isit_type(arg_4(arguments));
1122 result_type = take_type(arg_4(arguments));
1123 result_var_name = arg_6(arguments);
1124 result_init = arg_8(arguments);
1125 block_body = arg_10(arguments);
1126 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1127 block_body->value.listValue != NULL &&
1128 block_body->value.listValue->next == NULL) {
1129 block_body_list = block_body;
1130 block_body = block_body->value.listValue->obj;
1131 } /* if */
1132 block_body = copy_expression(block_body, &err_info);
1133 if (err_info == OKAY_NO_ERROR) {
1134 push_stack();
1135 /* printf("result_type ");
1136 trace1(result_type->match_obj);
1137 printf("\n");
1138 printf("result_var_name ");
1139 trace1(result_var_name);
1140 printf("\n"); */
1141 /* printf("result_init %lu ", (long unsigned) result_init);
1142 trace1(result_init);
1143 printf("\n"); */
1144 grow_stack(&err_info);
1145 if (err_info == OKAY_NO_ERROR) {
1146 result_var.object = entername(prog->declaration_root, result_var_name, &err_info);
1147 shrink_stack();
1148 } /* if */
1149 if (err_info == OKAY_NO_ERROR) {
1150 get_result_var(&result_var, result_type, result_init, &err_info);
1151 /* printf("result_var.object ");
1152 trace1(result_var.object);
1153 printf("\n");
1154 printf("result_var.init_value ");
1155 trace1(result_var.init_value);
1156 printf("\n"); */
1157 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1158 update_owner(block_body);
1159 block_body = match_expression(block_body);
1160 } /* if */
1161 if (block_body != NULL) {
1162 block_body = match_object(block_body);
1163 fix_posinfo(block_body, block_body_list);
1164 } /* if */
1165 if (block_body != NULL && block_body->type_of != take_type(SYS_PROC_TYPE)) {
1166 err_type(PROC_EXPECTED, block_body->type_of);
1167 } /* if */
1168 } /* if */
1169 pop_stack();
1170 } /* if */
1171 if (unlikely(err_info != OKAY_NO_ERROR ||
1172 block_body == NULL ||
1173 (block = new_block(NULL, &result_var, NULL, NULL, block_body)) == NULL)) {
1174 logError(printf("prc_res_begin: No memory\n"););
1175 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1176 } else {
1177 logFunction(printf("prc_res_begin -->\n"););
1178 return bld_block_temp(block);
1179 } /* if */
1180 } /* prc_res_begin */
1181
1182
1183
prc_res_local(listType arguments)1184 objectType prc_res_local (listType arguments)
1185
1186 {
1187 typeType result_type;
1188 objectType result_var_name;
1189 locObjRecord result_var;
1190 objectType result_init;
1191 objectType local_decls;
1192 objectType block_body;
1193 objectType block_body_list = NULL;
1194 listType *local_object_insert_place;
1195 locListType local_vars;
1196 listType local_consts;
1197 objectType decl_res;
1198 errInfoType err_info = OKAY_NO_ERROR;
1199 blockType block;
1200
1201 /* prc_res_local */
1202 logFunction(printf("prc_res_local\n"););
1203 isit_type(arg_4(arguments));
1204 result_type = take_type(arg_4(arguments));
1205 result_var_name = arg_6(arguments);
1206 result_init = arg_8(arguments);
1207 local_decls = arg_10(arguments);
1208 block_body = arg_12(arguments);
1209 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1210 block_body->value.listValue != NULL &&
1211 block_body->value.listValue->next == NULL) {
1212 block_body_list = block_body;
1213 block_body = block_body->value.listValue->obj;
1214 } /* if */
1215 block_body = copy_expression(block_body, &err_info);
1216 if (err_info == OKAY_NO_ERROR) {
1217 push_stack();
1218 grow_stack(&err_info);
1219 if (err_info == OKAY_NO_ERROR) {
1220 result_var.object = entername(prog->declaration_root, result_var_name, &err_info);
1221 shrink_stack();
1222 } /* if */
1223 if (err_info == OKAY_NO_ERROR) {
1224 get_result_var(&result_var, result_type, result_init, &err_info);
1225 local_object_insert_place = get_local_object_insert_place();
1226 decl_res = evaluate_local_decls(local_decls, local_object_insert_place, &err_info);
1227 if (decl_res != SYS_EMPTY_OBJECT) {
1228 /* printf("eval local decls --> ");
1229 trace1(decl_res);
1230 printf("\n");
1231 trace1(SYS_EMPTY_OBJECT);
1232 printf("\n"); */
1233 err_object(PROC_EXPECTED, decl_res);
1234 } /* if */
1235 local_vars = get_local_var_list(*local_object_insert_place, &err_info);
1236 local_consts = get_local_const_list(*local_object_insert_place, &err_info);
1237 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1238 update_owner(block_body);
1239 block_body = match_expression(block_body);
1240 } /* if */
1241 if (block_body != NULL) {
1242 block_body = match_object(block_body);
1243 fix_posinfo(block_body, block_body_list);
1244 } /* if */
1245 if (block_body != NULL && block_body->type_of != take_type(SYS_PROC_TYPE)) {
1246 err_type(PROC_EXPECTED, block_body->type_of);
1247 } /* if */
1248 } /* if */
1249 pop_stack();
1250 } /* if */
1251 if (unlikely(err_info != OKAY_NO_ERROR ||
1252 block_body == NULL ||
1253 (block = new_block(NULL, &result_var, local_vars, local_consts, block_body)) == NULL)) {
1254 logError(printf("prc_res_local: No memory\n"););
1255 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1256 } else {
1257 logFunction(printf("prc_res_local -->\n"););
1258 return bld_block_temp(block);
1259 } /* if */
1260 } /* prc_res_local */
1261
1262
1263
prc_return(listType arguments)1264 objectType prc_return (listType arguments)
1265
1266 {
1267 objectType block_body;
1268 objectType block_body_list = NULL;
1269 locObjRecord return_var;
1270 typeType return_type;
1271 errInfoType err_info = OKAY_NO_ERROR;
1272 blockType block;
1273
1274 /* prc_return */
1275 logFunction(printf("prc_return\n"););
1276 block_body = arg_2(arguments);
1277 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1278 block_body->value.listValue != NULL &&
1279 block_body->value.listValue->next == NULL) {
1280 block_body_list = block_body;
1281 block_body = block_body->value.listValue->obj;
1282 } /* if */
1283 block_body = copy_expression(block_body, &err_info);
1284 if (err_info == OKAY_NO_ERROR) {
1285 push_stack();
1286 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1287 update_owner(block_body);
1288 block_body = match_expression(block_body);
1289 } /* if */
1290 if (block_body != NULL) {
1291 block_body = match_object(block_body);
1292 fix_posinfo(block_body, block_body_list);
1293 } /* if */
1294 pop_stack();
1295 #ifdef OUT_OF_ORDER
1296 printf("prc_return block_body=");
1297 trace1(block_body);
1298 printf("\n");
1299 #endif
1300 if (block_body != NULL) {
1301 return_type = block_body->type_of;
1302 if (return_type->result_type != NULL) {
1303 return_type = return_type->result_type;
1304 } /* if */
1305 } else {
1306 return_type = NULL;
1307 } /* if */
1308 #ifdef OUT_OF_ORDER
1309 printf("return_type=");
1310 trace1(return_type->match_obj);
1311 printf("\n");
1312 #endif
1313 get_return_var(&return_var, return_type, &err_info);
1314 } /* if */
1315 if (unlikely(err_info != OKAY_NO_ERROR ||
1316 block_body == NULL ||
1317 (block = new_block(NULL, &return_var, NULL, NULL, block_body)) == NULL)) {
1318 logError(printf("prc_return: No memory\n"););
1319 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1320 } else {
1321 logFunction(printf("prc_return -->\n"););
1322 return bld_block_temp(block);
1323 } /* if */
1324 } /* prc_return */
1325
1326
1327
prc_return2(listType arguments)1328 objectType prc_return2 (listType arguments)
1329
1330 {
1331 objectType block_body;
1332 objectType block_body_list = NULL;
1333 locObjRecord return_var;
1334 typeType return_type;
1335 errInfoType err_info = OKAY_NO_ERROR;
1336 blockType block;
1337
1338 /* prc_return2 */
1339 logFunction(printf("prc_return2\n"););
1340 block_body = arg_3(arguments);
1341 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1342 block_body->value.listValue != NULL &&
1343 block_body->value.listValue->next == NULL) {
1344 block_body_list = block_body;
1345 block_body = block_body->value.listValue->obj;
1346 } /* if */
1347 block_body = copy_expression(block_body, &err_info);
1348 if (err_info == OKAY_NO_ERROR) {
1349 push_stack();
1350 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1351 update_owner(block_body);
1352 block_body = match_expression(block_body);
1353 } /* if */
1354 if (block_body != NULL) {
1355 block_body = match_object(block_body);
1356 fix_posinfo(block_body, block_body_list);
1357 } /* if */
1358 pop_stack();
1359 #ifdef OUT_OF_ORDER
1360 printf("prc_return2 block_body=");
1361 trace1(block_body);
1362 printf("\n");
1363 #endif
1364 if (block_body != NULL) {
1365 return_type = block_body->type_of;
1366 if (return_type->result_type != NULL) {
1367 return_type = return_type->result_type;
1368 } /* if */
1369 } else {
1370 return_type = NULL;
1371 } /* if */
1372 #ifdef OUT_OF_ORDER
1373 printf("return_type=");
1374 trace1(return_type->match_obj);
1375 printf("\n");
1376 #endif
1377 get_return_var(&return_var, return_type, &err_info);
1378 } /* if */
1379 if (unlikely(err_info != OKAY_NO_ERROR ||
1380 block_body == NULL ||
1381 (block = new_block(NULL, &return_var, NULL, NULL, block_body)) == NULL)) {
1382 logError(printf("prc_return2: No memory\n"););
1383 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1384 } else {
1385 logFunction(printf("prc_return2 -->\n"););
1386 return bld_block_temp(block);
1387 } /* if */
1388 } /* prc_return2 */
1389
1390
1391
prc_settrace(listType arguments)1392 objectType prc_settrace (listType arguments)
1393
1394 { /* prc_settrace */
1395 isit_stri(arg_1(arguments));
1396 mapTraceFlags(take_stri(arg_1(arguments)), &prog->option_flags);
1397 set_trace(prog->option_flags);
1398 return SYS_EMPTY_OBJECT;
1399 } /* prc_settrace */
1400
1401
1402
prc_trace(listType arguments)1403 objectType prc_trace (listType arguments)
1404
1405 { /* prc_trace */
1406 while (arguments != NULL) {
1407 trace1(arguments->obj);
1408 prot_nl();
1409 arguments = arguments->next;
1410 } /* while */
1411 return SYS_EMPTY_OBJECT;
1412 } /* prc_trace */
1413
1414
1415
prc_varfunc(listType arguments)1416 objectType prc_varfunc (listType arguments)
1417
1418 {
1419 objectType block_body;
1420 objectType block_body_list = NULL;
1421 errInfoType err_info = OKAY_NO_ERROR;
1422 blockType block;
1423
1424 /* prc_varfunc */
1425 logFunction(printf("prc_varfunc\n"););
1426 block_body = arg_3(arguments);
1427 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1428 block_body->value.listValue != NULL &&
1429 block_body->value.listValue->next == NULL) {
1430 block_body_list = block_body;
1431 block_body = block_body->value.listValue->obj;
1432 } /* if */
1433 block_body = copy_expression(block_body, &err_info);
1434 if (err_info == OKAY_NO_ERROR) {
1435 push_stack();
1436 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1437 update_owner(block_body);
1438 block_body = match_expression(block_body);
1439 } /* if */
1440 if (block_body != NULL) {
1441 block_body = match_object(block_body);
1442 fix_posinfo(block_body, block_body_list);
1443 } /* if */
1444 pop_stack();
1445 } /* if */
1446 if (unlikely(err_info != OKAY_NO_ERROR ||
1447 block_body == NULL ||
1448 (block = new_block(NULL, NULL, NULL, NULL, block_body)) == NULL)) {
1449 logError(printf("prc_varfunc: No memory\n"););
1450 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1451 } else {
1452 logFunction(printf("prc_varfunc -->\n"););
1453 return bld_block_temp(block);
1454 } /* if */
1455 } /* prc_varfunc */
1456
1457
1458
prc_varfunc2(listType arguments)1459 objectType prc_varfunc2 (listType arguments)
1460
1461 {
1462 objectType block_body;
1463 objectType block_body_list = NULL;
1464 errInfoType err_info = OKAY_NO_ERROR;
1465 blockType block;
1466
1467 /* prc_varfunc2 */
1468 logFunction(printf("prc_varfunc2\n"););
1469 block_body = arg_4(arguments);
1470 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT &&
1471 block_body->value.listValue != NULL &&
1472 block_body->value.listValue->next == NULL) {
1473 block_body_list = block_body;
1474 block_body = block_body->value.listValue->obj;
1475 } /* if */
1476 block_body = copy_expression(block_body, &err_info);
1477 if (err_info == OKAY_NO_ERROR) {
1478 push_stack();
1479 if (CATEGORY_OF_OBJ(block_body) == EXPROBJECT) {
1480 update_owner(block_body);
1481 block_body = match_expression(block_body);
1482 } /* if */
1483 if (block_body != NULL) {
1484 block_body = match_object(block_body);
1485 fix_posinfo(block_body, block_body_list);
1486 } /* if */
1487 pop_stack();
1488 } /* if */
1489 if (unlikely(err_info != OKAY_NO_ERROR ||
1490 block_body == NULL ||
1491 (block = new_block(NULL, NULL, NULL, NULL, block_body)) == NULL)) {
1492 logError(printf("prc_varfunc2: No memory\n"););
1493 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
1494 } else {
1495 logFunction(printf("prc_varfunc2 -->\n"););
1496 return bld_block_temp(block);
1497 } /* if */
1498 } /* prc_varfunc2 */
1499
1500
1501
prc_while(listType arguments)1502 objectType prc_while (listType arguments)
1503
1504 {
1505 objectType condition;
1506 objectType statement;
1507 objectType cond_value;
1508 boolType cond;
1509
1510 /* prc_while */
1511 condition = arg_2(arguments);
1512 statement = arg_4(arguments);
1513 cond_value = evaluate(condition);
1514 if (likely(!fail_flag)) {
1515 isit_bool(cond_value);
1516 cond = (boolType) (take_bool(cond_value) == SYS_TRUE_OBJECT);
1517 if (TEMP_OBJECT(cond_value)) {
1518 dump_any_temp(cond_value);
1519 } /* if */
1520 while (cond && !fail_flag) {
1521 evaluate(statement);
1522 if (likely(!fail_flag)) {
1523 cond_value = evaluate(condition);
1524 if (likely(!fail_flag)) {
1525 isit_bool(cond_value);
1526 cond = (boolType) (take_bool(cond_value) == SYS_TRUE_OBJECT);
1527 if (TEMP_OBJECT(cond_value)) {
1528 dump_any_temp(cond_value);
1529 } /* if */
1530 } /* if */
1531 } /* if */
1532 } /* while */
1533 } /* if */
1534 return SYS_EMPTY_OBJECT;
1535 } /* prc_while */
1536
1537
1538
prc_while_noop(listType arguments)1539 objectType prc_while_noop (listType arguments)
1540
1541 {
1542 objectType condition;
1543 objectType cond_value;
1544 boolType cond;
1545
1546 /* prc_while_noop */
1547 condition = arg_2(arguments);
1548 do {
1549 cond_value = evaluate(condition);
1550 if (likely(!fail_flag)) {
1551 isit_bool(cond_value);
1552 cond = (boolType) (take_bool(cond_value) == SYS_TRUE_OBJECT);
1553 if (TEMP_OBJECT(cond_value)) {
1554 dump_any_temp(cond_value);
1555 } /* if */
1556 } /* if */
1557 } while (cond && !fail_flag);
1558 return SYS_EMPTY_OBJECT;
1559 } /* prc_while_noop */
1560