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