1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2013, 2015, 2016, 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: Seed7 compiler library */
22 /* File: seed7/src/prg_comp.c */
23 /* Changes: 1991 - 1994, 2008, 2013, 2015, 2016 Thomas Mertes */
24 /* 2021 Thomas Mertes */
25 /* Content: Primitive actions for the program type. */
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
38 #include "common.h"
39 #include "sigutl.h"
40 #include "data.h"
41 #include "data_rtl.h"
42 #include "heaputl.h"
43 #include "flistutl.h"
44 #include "striutl.h"
45 #include "listutl.h"
46 #include "entutl.h"
47 #include "typeutl.h"
48 #include "syvarutl.h"
49 #include "identutl.h"
50 #include "traceutl.h"
51 #include "infile.h"
52 #include "analyze.h"
53 #include "name.h"
54 #include "exec.h"
55 #include "option.h"
56 #include "match.h"
57 #include "objutl.h"
58 #include "runerr.h"
59 #include "str_rtl.h"
60 #include "set_rtl.h"
61 #include "rtl_err.h"
62
63 #undef EXTERN
64 #define EXTERN
65 #include "prg_comp.h"
66
67
68 extern boolType interpreter_exception;
69
70
71
copy_args(const const_rtlArrayType argv,const memSizeType start)72 static objectType copy_args (const const_rtlArrayType argv, const memSizeType start)
73
74 {
75 memSizeType argc;
76 arrayType arg_array;
77 memSizeType arg_idx;
78 objectType result;
79
80 /* copy_args */
81 /* printf("start = %d\n", start); */
82 if (argv == NULL || argv->max_position < 0) {
83 argc = 0;
84 } else {
85 argc = (memSizeType) argv->max_position - start;
86 } /* if */
87 /* printf("argc = %d\n", argc); */
88 if (ALLOC_ARRAY(arg_array, argc)) {
89 arg_idx = 0;
90 while (arg_idx < argc) {
91 /* printf("arg_idx = %d\n", arg_idx);
92 printf("argv[%d] = ", start + arg_idx);
93 prot_stri(argv->arr[start + arg_idx].value.striValue);
94 printf("\n"); */
95 arg_array->arr[arg_idx].type_of = take_type(SYS_STRI_TYPE);
96 arg_array->arr[arg_idx].descriptor.property = NULL;
97 arg_array->arr[arg_idx].value.striValue =
98 argv->arr[start + arg_idx].value.striValue;
99 INIT_CATEGORY_OF_OBJ(&arg_array->arr[arg_idx], STRIOBJECT);
100 arg_idx++;
101 } /* while */
102 arg_array->min_position = 1;
103 arg_array->max_position = (intType) arg_idx;
104 } /* if */
105 if (arg_array != NULL) {
106 if (ALLOC_OBJECT(result)) {
107 result->type_of = NULL;
108 result->descriptor.property = NULL;
109 INIT_CATEGORY_OF_OBJ(result, ARRAYOBJECT);
110 result->value.arrayValue = arg_array;
111 } else {
112 FREE_ARRAY(arg_array, argc);
113 } /* if */
114 } else {
115 result = NULL;
116 } /* if */
117 return result;
118 } /* copy_args */
119
120
121
free_args(objectType arg_v)122 static void free_args (objectType arg_v)
123
124 {
125 arrayType arg_array;
126 memSizeType arg_array_size;
127
128 /* free_args */
129 arg_array = take_array(arg_v);
130 arg_array_size = arraySize(arg_array);
131 FREE_ARRAY(arg_array, arg_array_size);
132 FREE_OBJECT(arg_v);
133 } /* free_args */
134
135
136
interpret(const const_progType currentProg,const const_rtlArrayType argv,memSizeType argvStart,uintType options,const const_striType protFileName)137 void interpret (const const_progType currentProg, const const_rtlArrayType argv,
138 memSizeType argvStart, uintType options, const const_striType protFileName)
139
140 {
141 progType progBackup;
142 boolType backup_interpreter_exception;
143
144 /* interpret */
145 logFunction(printf("interpret(\"%s\")\n",
146 striAsUnquotedCStri(currentProg->program_path)););
147 if (currentProg != NULL) {
148 set_fail_flag(FALSE);
149 fail_value = NULL;
150 fail_expression = NULL;
151 fail_stack = NULL;
152 if (currentProg->main_object != NULL) {
153 progBackup = prog;
154 /* Cast to mutable structure */
155 prog = (progType) currentProg;
156 prog->option_flags = options;
157 setupSignalHandlers((options & HANDLE_SIGNALS) != 0,
158 (options & TRACE_SIGNALS) != 0,
159 FALSE, FALSE, doSuspendInterpreter);
160 set_trace(prog->option_flags);
161 set_protfile_name(protFileName);
162 if (prog->arg_v != NULL) {
163 free_args(prog->arg_v);
164 } /* if */
165 prog->arg_v = copy_args(argv, argvStart);
166 if (unlikely(prog->arg_v == NULL)) {
167 raise_error(MEMORY_ERROR);
168 } else {
169 /* printf("main defined as: ");
170 trace1(prog->main_object);
171 printf("\n"); */
172 #ifdef WITH_PROTOCOL
173 if (trace.actions) {
174 if (trace.heapsize) {
175 prot_heapsize();
176 prot_cstri(" ");
177 } /* if */
178 prot_cstri("begin main");
179 prot_nl();
180 } /* if */
181 #endif
182 backup_interpreter_exception = interpreter_exception;
183 interpreter_exception = TRUE;
184 evaluate(prog->main_object);
185 interpreter_exception = backup_interpreter_exception;
186 #ifdef WITH_PROTOCOL
187 if (trace.actions) {
188 if (trace.heapsize) {
189 prot_heapsize();
190 prot_cstri(" ");
191 } /* if */
192 prot_cstri("end main");
193 prot_nl();
194 } /* if */
195 #endif
196 #ifdef OUT_OF_ORDER
197 shutDrivers();
198 if (fail_flag) {
199 printf("\n*** Uncaught EXCEPTION ");
200 printobject(fail_value);
201 printf(" raised with\n");
202 prot_list(fail_expression);
203 printf("\n");
204 write_call_stack(fail_stack);
205 } /* if */
206 #endif
207 } /* if */
208 prog = progBackup;
209 } /* if */
210 } /* if */
211 logFunction(printf("interpret(\"%s\") -->\n",
212 striAsUnquotedCStri(currentProg->program_path)););
213 } /* interpret */
214
215
216
217 /**
218 * Assign source to *dest.
219 * A copy function assumes that *dest contains a legal value.
220 * @exception MEMORY_ERROR Not enough memory to create dest.
221 */
prgCpy(progType * const dest,const progType source)222 void prgCpy (progType *const dest, const progType source)
223
224 {
225 progType old_prog;
226
227 /* prgCpy */
228 old_prog = *dest;
229 if (old_prog != source) {
230 prgDestr(old_prog);
231 *dest = source;
232 if (source != NULL) {
233 source->usage_count++;
234 } /* if */
235 } /* if */
236 /* printf("prgCpy: usage_count=%d\n", (*dest)->usage_count); */
237 } /* prgCpy */
238
239
240
241 /**
242 * Return a copy of source, that can be assigned to a new destination.
243 * It is assumed that the destination of the assignment is undefined.
244 * Create functions can be used to initialize Seed7 constants.
245 * @return a copy of source.
246 * @exception MEMORY_ERROR Not enough memory to represent the result.
247 */
prgCreate(const progType source)248 progType prgCreate (const progType source)
249
250 {
251
252 /* prgCreate */
253 if (source != NULL) {
254 source->usage_count++;
255 } /* if */
256 /* printf("prgCreate: usage_count=%d\n", source->usage_count); */
257 return source;
258 } /* prgCreate */
259
260
261
262 /**
263 * Free the memory referred by 'old_prog'.
264 * After prgDestr is left 'old_prog' refers to not existing memory.
265 * The memory where 'old_prog' is stored can be freed afterwards.
266 */
prgDestr(progType old_prog)267 void prgDestr (progType old_prog)
268
269 {
270 progType progBackup;
271
272 /* prgDestr */
273 logFunction(printf("prgDestr(%lx)\n", (unsigned long) old_prog););
274 if (old_prog != NULL) {
275 /* printf("prgDestr: usage_count=%d\n", old_prog->usage_count); */
276 old_prog->usage_count--;
277 if (old_prog->usage_count == 0) {
278 /* printf("prgDestr: old progType: %lx\n", old_prog); */
279 progBackup = prog;
280 prog = old_prog;
281 /* printf("heapsize: %ld\n", heapsize()); */
282 /* heapStatistic(); */
283 dump_list(old_prog->exec_expr_temp_results);
284 close_stack(old_prog);
285 close_declaration_root(old_prog);
286 close_entity(old_prog);
287 close_idents(old_prog);
288 close_type(old_prog);
289 removeProgFiles(old_prog);
290 dump_list(old_prog->literals);
291 free_entity(old_prog, old_prog->entity.literal);
292 if (old_prog->property.literal != NULL) {
293 FREE_RECORD(old_prog->property.literal, propertyRecord, count.property);
294 } /* if */
295 prog = progBackup;
296 strDestr(old_prog->arg0);
297 strDestr(old_prog->program_name);
298 strDestr(old_prog->program_path);
299 if (old_prog->arg_v != NULL) {
300 free_args(old_prog->arg_v);
301 } /* if */
302 if (old_prog->stack_global != NULL) {
303 FREE_RECORD(old_prog->stack_global, stackRecord, count.stack);
304 } /* if */
305 FREE_RECORD(old_prog, progRecord, count.prog);
306 /* printf("heapsize: %ld\n", heapsize()); */
307 /* heapStatistic(); */
308 } /* if */
309 } /* if */
310 logFunction(printf("prgDestr\n"););
311 } /* prgDestr */
312
313
314
315 /**
316 * Determine the number of errors in 'aProgram'.
317 * @return the number of errors.
318 */
prgErrorCount(const const_progType aProgram)319 intType prgErrorCount (const const_progType aProgram)
320
321 {
322 intType result;
323
324 /* prgErrorCount */
325 if (unlikely(aProgram->error_count > INTTYPE_MAX)) {
326 raise_error(RANGE_ERROR);
327 result = 0;
328 } else {
329 result = (intType) aProgram->error_count;
330 } /* if */
331 return result;
332 } /* prgErrorCount */
333
334
335
336 /**
337 * Evaluate 'anExpression' which is part of 'aProgram'.
338 * @return the result of the evaluation.
339 */
prgEval(progType aProgram,objectType anExpression)340 objectType prgEval (progType aProgram, objectType anExpression)
341
342 {
343 errInfoType err_info = OKAY_NO_ERROR;
344 objectType result;
345
346 /* prgEval */
347 result = exec_expr(aProgram, anExpression, &err_info);
348 if (unlikely(err_info != OKAY_NO_ERROR)) {
349 raise_error(err_info);
350 result = NULL;
351 } /* if */
352 return result;
353 } /* prgEval */
354
355
356
357 /**
358 * Execute the program referred by 'aProgram'.
359 */
prgExec(const const_progType aProgram,const const_rtlArrayType parameters,const const_setType options,const const_striType protFileName)360 void prgExec (const const_progType aProgram, const const_rtlArrayType parameters,
361 const const_setType options, const const_striType protFileName)
362
363 {
364 uintType int_options;
365
366 /* prgExec */
367 logFunction(printf("prgExec(\"%s\")\n",
368 striAsUnquotedCStri(aProgram->program_path)););
369 int_options = (uintType) setSConv(options);
370 interpret(aProgram, parameters, 0, int_options, protFileName);
371 set_fail_flag(FALSE);
372 fail_value = NULL;
373 fail_expression = NULL;
374 logFunction(printf("prgExec(\"%s\") -->\n",
375 striAsUnquotedCStri(aProgram->program_path)););
376 } /* prgExec */
377
378
379
380 /**
381 * Parse the file with the name 'fileName'.
382 * @param fileName File name of the file to be parsed.
383 * @param options Options to be used when the file is parsed.
384 * @param libraryDirs Search path for include/library files.
385 * @param protFileName Name of the protocol file.
386 * @return the parsed program.
387 * @exception RANGE_ERROR 'fileName' does not use the standard path
388 * representation or 'fileName' is not representable in
389 * the system path type.
390 * @exception MEMORY_ERROR An out of memory situation occurred.
391 */
prgFilParse(const const_striType fileName,const const_setType options,const const_rtlArrayType libraryDirs,const const_striType protFileName)392 progType prgFilParse (const const_striType fileName, const const_setType options,
393 const const_rtlArrayType libraryDirs, const const_striType protFileName)
394
395 {
396 uintType int_options;
397 errInfoType err_info = OKAY_NO_ERROR;
398 progType resultProg;
399
400 /* prgFilParse */
401 logFunction(printf("prgFilParse(\"%s\")\n", striAsUnquotedCStri(fileName)););
402 int_options = (uintType) setSConv(options);
403 /* printf("options: 0x" F_X(016) "\n", int_options); */
404 resultProg = analyzeFile(fileName, int_options, libraryDirs, protFileName, &err_info);
405 if (unlikely(err_info != OKAY_NO_ERROR)) {
406 logError(printf("prgFilParse(\"%s\"): analyzeFile() failed:\n"
407 "int_options=0x" F_X(016) "\nerr_info=%d\n",
408 striAsUnquotedCStri(fileName), int_options, err_info););
409 raise_error(err_info);
410 } /* if */
411 logFunction(printf("prgFilParse --> " FMT_U_MEM "\n",
412 (memSizeType) resultProg););
413 return resultProg;
414 } /* prgFilParse */
415
416
417
418 /**
419 * Determine the list of global defined objects in 'aProgram'.
420 * The returned list contains constant and variable objects
421 * in the same order as the definitions of the source program.
422 * Literal objects and local objects are not part of this list.
423 * @return the list of global defined objects.
424 */
prgGlobalObjects(const const_progType aProgram)425 listType prgGlobalObjects (const const_progType aProgram)
426
427 {
428 errInfoType err_info = OKAY_NO_ERROR;
429 listType result;
430
431 /* prgGlobalObjects */
432 if (aProgram->stack_current != NULL) {
433 result = copy_list(aProgram->stack_global->local_object_list, &err_info);
434 if (unlikely(err_info != OKAY_NO_ERROR)) {
435 raise_error(MEMORY_ERROR);
436 result = NULL;
437 } /* if */
438 } else {
439 result = NULL;
440 } /* if */
441 return result;
442 } /* prgGlobalObjects */
443
444
445
prgMatch(const const_progType aProg,listType curr_expr)446 objectType prgMatch (const const_progType aProg, listType curr_expr)
447
448 {
449 objectRecord expr_object;
450 objectType result;
451
452 /* prgMatch */
453 /* prot_list(curr_expr);
454 printf("\n"); */
455 expr_object.type_of = NULL;
456 expr_object.descriptor.property = NULL;
457 expr_object.value.listValue = curr_expr;
458 INIT_CATEGORY_OF_OBJ(&expr_object, EXPROBJECT);
459
460 result = match_prog_expression(aProg->declaration_root, &expr_object);
461 if (result != NULL) {
462 if (CATEGORY_OF_OBJ(result) == MATCHOBJECT ||
463 CATEGORY_OF_OBJ(result) == CALLOBJECT) {
464 curr_expr = expr_object.value.listValue->next;
465 result = expr_object.value.listValue->obj;
466 expr_object.value.listValue->next = NULL;
467 free_list(expr_object.value.listValue);
468 } else {
469 run_error(MATCHOBJECT, result);
470 } /* if */
471 } /* if */
472 /* printf("result == %lx\n", result);
473 trace1(result);
474 printf("\n");
475 prot_list(curr_expr);
476 printf("\n"); */
477 return result;
478 } /* prgMatch */
479
480
481
prgMatchExpr(const const_progType aProg,listType curr_expr)482 objectType prgMatchExpr (const const_progType aProg, listType curr_expr)
483
484 {
485 errInfoType err_info = OKAY_NO_ERROR;
486 objectType result;
487
488 /* prgMatchExpr */
489 /* prot_list(curr_expr);
490 printf("\n"); */
491 if (unlikely(!ALLOC_OBJECT(result))) {
492 raise_error(MEMORY_ERROR);
493 result = NULL;
494 } else {
495 result->type_of = NULL;
496 result->descriptor.property = NULL;
497 INIT_CATEGORY_OF_OBJ(result, EXPROBJECT);
498 result->value.listValue = copy_list(curr_expr, &err_info);
499 if (unlikely(err_info != OKAY_NO_ERROR)) {
500 raise_error(MEMORY_ERROR);
501 result = NULL;
502 } else {
503 result = match_prog_expression(aProg->declaration_root, result);
504 /* printf("result == %lx\n", result);
505 trace1(result);
506 printf("\n");
507 prot_list(curr_expr);
508 printf("\n");
509 prot_list(result->value.listValue);
510 printf("\n"); */
511 } /* if */
512 } /* if */
513 return result;
514 } /* prgMatchExpr */
515
516
517
518 /**
519 * Returns the name of the program without path and extension.
520 * This function does not follow symbolic links.
521 * It determines, with which name a program was called.
522 * If a symbolic link refers to a program, the name of
523 * the symbolic link is returned.
524 * @return the name of the program.
525 */
prgName(const const_progType aProg)526 const_striType prgName (const const_progType aProg)
527
528 { /* prgName */
529 return aProg->program_name;
530 } /* prgName */
531
532
533
534 /**
535 * Return the absolute path of the program 'aProg'.
536 * This function does follow symbolic links.
537 * @return the absolute path of the program.
538 */
prgPath(const const_progType aProg)539 const_striType prgPath (const const_progType aProg)
540
541 { /* prgPath */
542 return aProg->program_path;
543 } /* prgPath */
544
545
546
547 /**
548 * Parse the given 'string'.
549 * @param stri 'String' to be parsed.
550 * @param options Options to be used when the file is parsed.
551 * @param libraryDirs Search path for include/library files.
552 * @param protFileName Name of the protocol file.
553 * @return the parsed program.
554 * @exception MEMORY_ERROR An out of memory situation occurred.
555 */
prgStrParse(const const_striType stri,const const_setType options,const const_rtlArrayType libraryDirs,const const_striType protFileName)556 progType prgStrParse (const const_striType stri, const const_setType options,
557 const const_rtlArrayType libraryDirs, const const_striType protFileName)
558
559 {
560 uintType int_options;
561 errInfoType err_info = OKAY_NO_ERROR;
562 progType result;
563
564 /* prgStrParse */
565 logFunction(printf("prgStrParse(\"%s\")\n", striAsUnquotedCStri(stri)););
566 int_options = (uintType) setSConv(options);
567 result = analyzeString(stri, int_options, libraryDirs, protFileName, &err_info);
568 if (unlikely(err_info != OKAY_NO_ERROR)) {
569 logError(printf("prgStrParse(\"%s\"): analyzeString() failed:\n"
570 "int_options=" F_X(03) "\nerr_info=%d\n",
571 striAsUnquotedCStri(stri), int_options, err_info););
572 raise_error(err_info);
573 } /* if */
574 return result;
575 } /* prgStrParse */
576
577
578
579 /**
580 * Determine object with 'syobjectName' from program 'aProgram'.
581 * @return a reference to the object, and
582 * NIL if no object 'syobjectName' exists.
583 * @exception MEMORY_ERROR If 'syobjectName' cannot be converted to
584 * the internal representation.
585 */
prgSyobject(const progType aProgram,const const_striType syobjectName)586 objectType prgSyobject (const progType aProgram, const const_striType syobjectName)
587
588 {
589 cstriType name;
590 identType ident_found;
591 errInfoType err_info = OKAY_NO_ERROR;
592 objectType result;
593
594 /* prgSyobject */
595 name = stri_to_cstri8(syobjectName, &err_info);
596 if (unlikely(name == NULL)) {
597 raise_error(err_info);
598 result = NULL;
599 } else {
600 ident_found = get_ident(aProgram, (const_ustriType) name);
601 if (ident_found == NULL ||
602 ident_found->entity == NULL) {
603 result = NULL;
604 } else {
605 result = ident_found->entity->syobject;
606 } /* if */
607 free_cstri8(name, syobjectName);
608 } /* if */
609 return result;
610 } /* prgSyobject */
611
612
613
614 /**
615 * Determine the value of the system variable 'name' in 'aProgram'.
616 * @return a reference to the value of the system variable, and
617 * NIL if no system variable 'name' exists.
618 */
prgSysvar(const const_progType aProgram,const const_striType name)619 objectType prgSysvar (const const_progType aProgram, const const_striType name)
620
621 {
622 int index_found;
623 objectType result;
624
625 /* prgSysvar */
626 index_found = findSysvar(name);
627 if (index_found != -1) {
628 result = aProgram->sys_var[index_found];
629 } else {
630 result = NULL;
631 } /* if */
632 return result;
633 } /* prgSysvar */
634