1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2013 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/prglib.c */
23 /* Changes: 1991 - 1994, 2008, 2013 - 2016 Thomas Mertes */
24 /* Content: All primitive actions for the program type. */
25 /* */
26 /********************************************************************/
27
28 #define LOG_FUNCTIONS 0
29 #define VERBOSE_EXCEPTIONS 0
30
31 #include "version.h"
32
33 #include "stdlib.h"
34 #include "stdio.h"
35 #include "string.h"
36
37 #include "common.h"
38 #include "data.h"
39 #include "data_rtl.h"
40 #include "heaputl.h"
41 #include "flistutl.h"
42 #include "syvarutl.h"
43 #include "striutl.h"
44 #include "identutl.h"
45 #include "listutl.h"
46 #include "arrutl.h"
47 #include "entutl.h"
48 #include "findid.h"
49 #include "traceutl.h"
50 #include "objutl.h"
51 #include "analyze.h"
52 #include "exec.h"
53 #include "runerr.h"
54 #include "match.h"
55 #include "name.h"
56 #include "str_rtl.h"
57 #include "prg_comp.h"
58
59 #undef EXTERN
60 #define EXTERN
61 #include "prglib.h"
62
63
64
65 /**
66 * Assign source/arg_3 to dest/arg_1.
67 * A copy function assumes that dest/arg_1 contains a legal value.
68 */
prg_cpy(listType arguments)69 objectType prg_cpy (listType arguments)
70
71 {
72 objectType dest;
73 objectType source;
74 progType old_prog;
75 progType prog_value;
76
77 /* prg_cpy */
78 dest = arg_1(arguments);
79 source = arg_3(arguments);
80 isit_prog(dest);
81 isit_prog(source);
82 is_variable(dest);
83 old_prog = take_prog(dest);
84 prog_value = take_prog(source);
85 if (old_prog != prog_value) {
86 prgDestr(old_prog);
87 dest->value.progValue = prog_value;
88 if (TEMP_OBJECT(source)) {
89 source->value.progValue = NULL;
90 } else {
91 if (prog_value != NULL) {
92 prog_value->usage_count++;
93 } /* if */
94 } /* if */
95 } /* if */
96 /* printf("prg_cpy: usage_count=%d\n", prog_value->usage_count); */
97 return SYS_EMPTY_OBJECT;
98 } /* prg_cpy */
99
100
101
102 /**
103 * Initialize dest/arg_1 and assign source/arg_3 to it.
104 * A create function assumes that the contents of dest/arg_1
105 * is undefined. Create functions can be used to initialize
106 * constants.
107 */
prg_create(listType arguments)108 objectType prg_create (listType arguments)
109
110 {
111 objectType source;
112 progType prog_value;
113
114 /* prg_create */
115 source = arg_3(arguments);
116 isit_prog(source);
117 SET_CATEGORY_OF_OBJ(arg_1(arguments), PROGOBJECT);
118 prog_value = take_prog(source);
119 arg_1(arguments)->value.progValue = prog_value;
120 if (TEMP_OBJECT(source)) {
121 source->value.progValue = NULL;
122 } else {
123 if (prog_value != NULL) {
124 prog_value->usage_count++;
125 } /* if */
126 } /* if */
127 return SYS_EMPTY_OBJECT;
128 } /* prg_create */
129
130
131
132 /**
133 * Free the memory referred by 'old_prog/arg_1'.
134 * After prg_destr is left 'old_prog/arg_1' is NULL.
135 * The memory where 'old_prog/arg_1' is stored can be
136 * freed afterwards.
137 */
prg_destr(listType arguments)138 objectType prg_destr (listType arguments)
139
140 { /* prg_destr */
141 isit_prog(arg_1(arguments));
142 prgDestr(take_prog(arg_1(arguments)));
143 arg_1(arguments)->value.progValue = NULL;
144 SET_UNUSED_FLAG(arg_1(arguments));
145 return SYS_EMPTY_OBJECT;
146 } /* prg_destr */
147
148
149
150 /**
151 * Get an empty program (a program that does not exist).
152 * @return an empty program.
153 */
prg_empty(listType arguments)154 objectType prg_empty (listType arguments)
155
156 { /* prg_empty */
157 return bld_prog_temp(NULL);
158 } /* prg_empty */
159
160
161
162 /**
163 * Check if two program values are equal.
164 * @return TRUE if both values are equal, FALSE otherwise.
165 */
prg_eq(listType arguments)166 objectType prg_eq (listType arguments)
167
168 { /* prg_eq */
169 isit_prog(arg_1(arguments));
170 isit_prog(arg_3(arguments));
171 if (take_prog(arg_1(arguments)) == take_prog(arg_3(arguments))) {
172 return SYS_TRUE_OBJECT;
173 } else {
174 return SYS_FALSE_OBJECT;
175 } /* if */
176 } /* prg_eq */
177
178
179
180 /**
181 * Determine the number of errors in 'aProgram/arg_1'.
182 * @return the number of errors.
183 */
prg_error_count(listType arguments)184 objectType prg_error_count (listType arguments)
185
186 { /* prg_error_count */
187 isit_prog(arg_1(arguments));
188 return bld_int_temp(prgErrorCount(
189 take_prog(arg_1(arguments))));
190 } /* prg_error_count */
191
192
193
194 /**
195 * Evaluate 'anExpression/arg_2' which is part of 'aProgram/arg_1'.
196 * @return the result of the evaluation.
197 */
prg_eval(listType arguments)198 objectType prg_eval (listType arguments)
199
200 {
201 errInfoType err_info = OKAY_NO_ERROR;
202 objectType result;
203
204 /* prg_eval */
205 isit_prog(arg_1(arguments));
206 isit_reference(arg_2(arguments));
207 result = exec_expr(take_prog(arg_1(arguments)),
208 take_reference(arg_2(arguments)),
209 &err_info);
210 if (err_info != OKAY_NO_ERROR) {
211 /* The global variable curr_argument_list does not contain */
212 /* the arguments of this function. Therefore the parameter */
213 /* arguments is used instead. */
214 return raise_with_arguments(prog->sys_var[err_info], arguments);
215 } else {
216 return bld_reference_temp(result);
217 } /* if */
218 } /* prg_eval */
219
220
221
222 /**
223 * Execute the program referred by 'aProgram/arg_1'.
224 */
prg_exec(listType arguments)225 objectType prg_exec (listType arguments)
226
227 {
228 rtlArrayType parameters;
229
230 /* prg_exec */
231 isit_prog(arg_1(arguments));
232 isit_array(arg_2(arguments));
233 isit_set(arg_3(arguments));
234 isit_stri(arg_4(arguments));
235 parameters = gen_rtl_array(take_array(arg_2(arguments)));
236 if (parameters == NULL) {
237 return raise_exception(SYS_MEM_EXCEPTION);
238 } else {
239 prgExec(take_prog(arg_1(arguments)),
240 parameters,
241 take_set(arg_3(arguments)),
242 take_stri(arg_4(arguments)));
243 FREE_RTL_ARRAY(parameters, ARRAY_LENGTH(parameters));
244 } /* if */
245 return SYS_EMPTY_OBJECT;
246 } /* prg_exec */
247
248
249
250 /**
251 * Parse the file with the name 'fileName/arg_1'.
252 * @param fileName/arg_1 File name of the file to be parsed.
253 * @param options/arg_2 Options to be used when the file is parsed.
254 * @param libraryDirs/arg_3 Search path for include/library files.
255 * @param protFileName/arg_4 Name of the protocol file.
256 * @return the parsed program.
257 * @exception RANGE_ERROR 'fileName/arg_1' does not use the standard path
258 * representation or 'fileName/arg_1' is not representable in
259 * the system path type.
260 * @exception MEMORY_ERROR An out of memory situation occurred.
261 */
prg_fil_parse(listType arguments)262 objectType prg_fil_parse (listType arguments)
263
264 {
265 rtlArrayType libraryDirs;
266 progType program;
267
268 /* prg_fil_parse */
269 isit_stri(arg_1(arguments));
270 isit_set(arg_2(arguments));
271 isit_array(arg_3(arguments));
272 isit_stri(arg_4(arguments));
273 libraryDirs = gen_rtl_array(take_array(arg_3(arguments)));
274 if (libraryDirs == NULL) {
275 return raise_exception(SYS_MEM_EXCEPTION);
276 } else {
277 program = prgFilParse(take_stri(arg_1(arguments)),
278 take_set(arg_2(arguments)),
279 libraryDirs,
280 take_stri(arg_4(arguments)));
281 FREE_RTL_ARRAY(libraryDirs, ARRAY_LENGTH(libraryDirs));
282 return bld_prog_temp(program);
283 } /* if */
284 } /* prg_fil_parse */
285
286
287
288 /**
289 * Determine the list of global defined objects in 'aProgram/arg_1'.
290 * The returned list contains constant and variable objects
291 * in the same order as the definitions of the source program.
292 * Literal objects and local objects are not part of this list.
293 * @return the list of global defined objects.
294 */
prg_global_objects(listType arguments)295 objectType prg_global_objects (listType arguments)
296
297 { /* prg_global_objects */
298 isit_prog(arg_1(arguments));
299 return bld_reflist_temp(prgGlobalObjects(
300 take_prog(arg_1(arguments))));
301 } /* prg_global_objects */
302
303
304
prg_match(listType arguments)305 objectType prg_match (listType arguments)
306
307 { /* prg_match */
308 isit_prog(arg_1(arguments));
309 isit_reflist(arg_2(arguments));
310 return bld_reference_temp(prgMatch(
311 take_prog(arg_1(arguments)), take_reflist(arg_2(arguments))));
312 } /* prg_match */
313
314
315
prg_match_expr(listType arguments)316 objectType prg_match_expr (listType arguments)
317
318 { /* prg_match_expr */
319 isit_prog(arg_1(arguments));
320 isit_reflist(arg_2(arguments));
321 return bld_reference_temp(prgMatchExpr(
322 take_prog(arg_1(arguments)), take_reflist(arg_2(arguments))));
323 } /* prg_match_expr */
324
325
326
327 /**
328 * Returns the name of 'aProg/arg_1' without path and extension.
329 * This function does not follow symbolic links.
330 * It determines, with which name a program was called.
331 * If a symbolic link refers to a program, the name of
332 * the symbolic link is returned.
333 * @return the name of the program.
334 */
prg_name(listType arguments)335 objectType prg_name (listType arguments)
336
337 { /* prg_name */
338 isit_prog(arg_1(arguments));
339 return bld_stri_temp(strCreate(take_prog(arg_1(arguments))->program_name));
340 } /* prg_name */
341
342
343
344 /**
345 * Check if two program values are not equal.
346 * @return FALSE if both values are equal, TRUE otherwise.
347 */
prg_ne(listType arguments)348 objectType prg_ne (listType arguments)
349
350 { /* prg_ne */
351 isit_prog(arg_1(arguments));
352 isit_prog(arg_3(arguments));
353 if (take_prog(arg_1(arguments)) != take_prog(arg_3(arguments))) {
354 return SYS_TRUE_OBJECT;
355 } else {
356 return SYS_FALSE_OBJECT;
357 } /* if */
358 } /* prg_ne */
359
360
361
362 /**
363 * Returns the name of the program without path and extension.
364 * This function does not follow symbolic links.
365 * It determines, with which name a program was called.
366 * If a symbolic link refers to a program, the name of
367 * the symbolic link is returned.
368 * @return the name of the program.
369 */
prg_own_name(listType arguments)370 objectType prg_own_name (listType arguments)
371
372 { /* prg_own_name */
373 return bld_stri_temp(strCreate(prog->program_name));
374 } /* prg_own_name */
375
376
377
378 /**
379 * Return the absolute path of the program.
380 * For an interpreted program this is the absolute path of the source file.
381 * For a compiled program this is the absolute path of the executable.
382 * The function 'prg_own_path' does follow symbolic links.
383 * @return the absolute path of the program.
384 */
prg_own_path(listType arguments)385 objectType prg_own_path (listType arguments)
386
387 { /* prg_own_path */
388 return bld_stri_temp(strCreate(prog->program_path));
389 } /* prg_own_path */
390
391
392
393 /**
394 * Return the absolute path of the program 'aProg/arg_1'.
395 * This function does follow symbolic links.
396 * @return the absolute path of the program.
397 */
prg_path(listType arguments)398 objectType prg_path (listType arguments)
399
400 { /* prg_path */
401 isit_prog(arg_1(arguments));
402 return bld_stri_temp(strCreate(take_prog(arg_1(arguments))->program_path));
403 } /* prg_path */
404
405
406
407 /**
408 * Parse the given string 'stri/arg_1'.
409 * @param stri/arg_1 'String' to be parsed.
410 * @param options/arg_2 Options to be used when the file is parsed.
411 * @param libraryDirs/arg_3 Search path for include/library files.
412 * @param protFileName/arg_4 Name of the protocol file.
413 * @return the parsed program.
414 * @exception MEMORY_ERROR An out of memory situation occurred.
415 */
prg_str_parse(listType arguments)416 objectType prg_str_parse (listType arguments)
417
418 {
419 rtlArrayType libraryDirs;
420 progType program;
421
422 /* prg_str_parse */
423 isit_stri(arg_1(arguments));
424 isit_set(arg_2(arguments));
425 isit_array(arg_3(arguments));
426 isit_stri(arg_4(arguments));
427 libraryDirs = gen_rtl_array(take_array(arg_3(arguments)));
428 if (libraryDirs == NULL) {
429 return raise_exception(SYS_MEM_EXCEPTION);
430 } else {
431 program = prgStrParse(take_stri(arg_1(arguments)),
432 take_set(arg_2(arguments)),
433 libraryDirs,
434 take_stri(arg_4(arguments)));
435 FREE_RTL_ARRAY(libraryDirs, ARRAY_LENGTH(libraryDirs));
436 return bld_prog_temp(program);
437 } /* if */
438 } /* prg_str_parse */
439
440
441
442 /**
443 * Determine object with 'syobjectName/arg_2' from program 'aProgram/arg_1'.
444 * @return a reference to the object, and
445 * NIL if no object 'syobjectName/arg_2' exists.
446 * @exception MEMORY_ERROR If 'syobjectName/arg_2' cannot be converted to
447 * the internal representation.
448 */
prg_syobject(listType arguments)449 objectType prg_syobject (listType arguments)
450
451 { /* prg_syobject */
452 isit_prog(arg_1(arguments));
453 isit_stri(arg_2(arguments));
454 return bld_reference_temp(prgSyobject(
455 take_prog(arg_1(arguments)), take_stri(arg_2(arguments))));
456 } /* prg_syobject */
457
458
459
460 /**
461 * Determine the value of the system variable 'name/arg_2' in 'aProgram/arg_1'.
462 * @return a reference to the value of the system variable, and
463 * NIL if no system variable 'name/arg_2' exists.
464 */
prg_sysvar(listType arguments)465 objectType prg_sysvar (listType arguments)
466
467 { /* prg_sysvar */
468 isit_prog(arg_1(arguments));
469 isit_stri(arg_2(arguments));
470 return bld_reference_temp(prgSysvar(
471 take_prog(arg_1(arguments)), take_stri(arg_2(arguments))));
472 } /* prg_sysvar */
473
474
475
476 /**
477 * Get 'program' value of the object referenced by 'aReference/arg_1'.
478 * @return the 'program' value of the referenced object.
479 * @exception RANGE_ERROR If 'aReference/arg_1' is NIL or
480 * category(aReference) <> PROGOBJECT holds.
481 */
prg_value(listType arguments)482 objectType prg_value (listType arguments)
483
484 {
485 objectType aReference;
486
487 /* prg_value */
488 isit_reference(arg_1(arguments));
489 aReference = take_reference(arg_1(arguments));
490 if (unlikely(aReference == NULL ||
491 CATEGORY_OF_OBJ(aReference) != PROGOBJECT)) {
492 logError(printf("prg_value(");
493 trace1(aReference);
494 printf("): Category is not PROGOBJECT.\n"););
495 return raise_exception(SYS_RNG_EXCEPTION);
496 } else {
497 return bld_prog_temp(take_prog(aReference));
498 } /* if */
499 } /* prg_value */
500