1 /********************************************************************/
2 /* */
3 /* s7 Seed7 interpreter */
4 /* Copyright (C) 1990 - 2005, 2008, 2013, 2015 Thomas Mertes */
5 /* 2019, 2021 Thomas Mertes */
6 /* */
7 /* This program is free software; you can redistribute it and/or */
8 /* modify it under the terms of the GNU General Public License as */
9 /* published by the Free Software Foundation; either version 2 of */
10 /* the License, or (at your option) any later version. */
11 /* */
12 /* This program is distributed in the hope that it will be useful, */
13 /* but WITHOUT ANY WARRANTY; without even the implied warranty of */
14 /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */
15 /* GNU General Public License for more details. */
16 /* */
17 /* You should have received a copy of the GNU General Public */
18 /* License along with this program; if not, write to the */
19 /* Free Software Foundation, Inc., 51 Franklin Street, */
20 /* Fifth Floor, Boston, MA 02110-1301, USA. */
21 /* */
22 /* Module: Library */
23 /* File: seed7/src/dcllib.c */
24 /* Changes: 1999, 2008, 2013, 2015, 2019, 2021 Thomas Mertes */
25 /* Content: Primitive actions to for simple declarations. */
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
37 #include "common.h"
38 #include "sigutl.h"
39 #include "data.h"
40 #include "heaputl.h"
41 #include "flistutl.h"
42 #include "syvarutl.h"
43 #include "traceutl.h"
44 #include "listutl.h"
45 #include "entutl.h"
46 #include "blockutl.h"
47 #include "executl.h"
48 #include "objutl.h"
49 #include "exec.h"
50 #include "runerr.h"
51 #include "name.h"
52 #include "match.h"
53 #include "error.h"
54
55 #undef EXTERN
56 #define EXTERN
57 #include "dcllib.h"
58
59 #define TRACE_DCL 0
60 #define TRACE_DCL_CONST 0
61 #define TRACE_DCL_VAR 0
62
63
64
dcl_attr(listType arguments)65 objectType dcl_attr (listType arguments)
66
67 {
68 typeType attribute_type;
69
70 /* dcl_attr */
71 isit_type(arg_2(arguments));
72 attribute_type = take_type(arg_2(arguments));
73 /* printf("decl attr ");
74 trace1(attribute_type->match_obj);
75 printf(":\n"); */
76 return bld_param_temp(attribute_type->match_obj);
77 } /* dcl_attr */
78
79
80
dcl_const(listType arguments)81 objectType dcl_const (listType arguments)
82
83 {
84 typeType object_type;
85 objectType name_expr;
86 objectType value_expr;
87 objectType value;
88 objectType matched_value;
89 objectType current_object;
90 errInfoType err_info = OKAY_NO_ERROR;
91
92 /* dcl_const */
93 isit_type(arg_2(arguments));
94 object_type = take_type(arg_2(arguments));
95 name_expr = arg_4(arguments);
96 value_expr = arg_6(arguments);
97 logFunction(printf("dcl_const\n"););
98 #if TRACE_DCL_CONST
99 printf("decl const object_type = ");
100 trace1(object_type->match_obj);
101 printf("\ndecl const name_expr = ");
102 trace1(name_expr);
103 printf("\ndecl const value_expr = ");
104 trace1(value_expr);
105 printf("\n");
106 #endif
107 grow_stack(&err_info);
108 if (err_info == OKAY_NO_ERROR) {
109 if (CATEGORY_OF_OBJ(value_expr) == EXPROBJECT &&
110 value_expr->value.listValue != NULL &&
111 value_expr->value.listValue->next == NULL) {
112 value_expr = value_expr->value.listValue->obj;
113 } /* if */
114 #if TRACE_DCL_CONST
115 printf("decl const value_expr = ");
116 trace1(value_expr);
117 printf("\n");
118 #endif
119 current_object = entername(prog->declaration_root, name_expr, &err_info);
120 /* printf(":%lu\n", (long unsigned) GET_ENTITY(current_object)); */
121 value = copy_expression(value_expr, &err_info);
122 if (err_info == OKAY_NO_ERROR) {
123 current_object->type_of = object_type;
124 #if TRACE_DCL_CONST
125 printf("decl const current_object = ");
126 trace1(current_object);
127 printf("\n");
128 #endif
129 if (CATEGORY_OF_OBJ(value) == EXPROBJECT) {
130 substitute_params(value);
131 if (match_expression(value) != NULL &&
132 (matched_value = match_object(value)) != NULL) {
133 do_create(current_object, matched_value, &err_info);
134 if (err_info == CREATE_ERROR) {
135 err_object(DECL_FAILED, current_object);
136 err_info = OKAY_NO_ERROR;
137 #if TRACE_DCL_CONST
138 printf("*** do_create failed ");
139 prot_list(arguments);
140 printf("\n");
141 #endif
142 } /* if */
143 #if TRACE_DCL_CONST
144 } else {
145 printf("match value failed: ");
146 trace1(value);
147 printf("\n");
148 printf("value_expr: ");
149 trace1(value_expr);
150 printf("\n");
151 printf("object: ");
152 trace1(current_object);
153 printf("\n");
154 printf("name_expr: ");
155 trace1(name_expr);
156 printf("\n");
157 #endif
158 } /* if */
159 } else {
160 do_create(current_object, value, &err_info);
161 if (err_info == CREATE_ERROR) {
162 err_object(DECL_FAILED, current_object);
163 err_info = OKAY_NO_ERROR;
164 #if TRACE_DCL_CONST
165 printf("*** do_create failed ");
166 prot_list(arguments);
167 printf("\n");
168 #endif
169 } /* if */
170 } /* if */
171 free_expression(value);
172 if (CATEGORY_OF_OBJ(current_object) == BLOCKOBJECT) {
173 current_object->value.blockValue->params =
174 get_param_list(current_object->descriptor.property->params, &err_info);
175 } /* if */
176 } /* if */
177 shrink_stack();
178 } /* if */
179 #if TRACE_DCL_CONST
180 printf("entity=%lu ", (unsigned long) GET_ENTITY(current_object));
181 printf("%lu ", (unsigned long) current_object);
182 printf("decl const current_object = ");
183 trace1(current_object);
184 printf("\n");
185 #endif
186 logFunction(printf("dcl_const --> err_info=%d\n", err_info););
187 if (unlikely(err_info != OKAY_NO_ERROR)) {
188 return raise_exception(SYS_MEM_EXCEPTION);
189 } else {
190 return SYS_EMPTY_OBJECT;
191 } /* if */
192 } /* dcl_const */
193
194
195
dcl_elements(listType arguments)196 objectType dcl_elements (listType arguments)
197
198 {
199 objectType local_decls;
200 listType *local_object_insert_place;
201 objectType decl_res;
202 listType element_list;
203 errInfoType err_info = OKAY_NO_ERROR;
204
205 /* dcl_elements */
206 local_decls = arg_1(arguments);
207 push_stack();
208 local_object_insert_place = get_local_object_insert_place();
209 decl_res = evaluate(local_decls);
210 if (decl_res != SYS_EMPTY_OBJECT) {
211 printf("eval local decls --> ");
212 trace1(decl_res);
213 printf("\n");
214 trace1(SYS_EMPTY_OBJECT);
215 printf("\n");
216 err_object(PROC_EXPECTED, decl_res);
217 } /* if */
218 element_list = copy_list(*local_object_insert_place, &err_info);
219 /* printf("before pop_stack\n"); */
220 pop_stack();
221 /* printf("after pop_stack\n"); */
222 if (unlikely(err_info != OKAY_NO_ERROR)) {
223 return raise_with_arguments(SYS_MEM_EXCEPTION, arguments);
224 } else {
225 return bld_reflist_temp(element_list);
226 } /* if */
227 } /* dcl_elements */
228
229
230
dcl_fwd(listType arguments)231 objectType dcl_fwd (listType arguments)
232
233 {
234 typeType object_type;
235 objectType name_expr;
236 objectType current_object;
237 errInfoType err_info = OKAY_NO_ERROR;
238
239 /* dcl_fwd */
240 isit_type(arg_2(arguments));
241 object_type = take_type(arg_2(arguments));
242 name_expr = arg_4(arguments);
243 #if TRACE_DCL
244 printf("\ndecl const object_type = ");
245 trace1(object_type->match_obj);
246 printf("\ndecl const name_expr = ");
247 trace1(name_expr);
248 printf("\n");
249 #endif
250 grow_stack(&err_info);
251 if (err_info == OKAY_NO_ERROR) {
252 current_object = entername(prog->declaration_root, name_expr, &err_info);
253 if (err_info == OKAY_NO_ERROR) {
254 current_object->type_of = object_type;
255 INIT_CATEGORY_OF_OBJ(current_object, FORWARDOBJECT);
256 } /* if */
257 shrink_stack();
258 } /* if */
259 #if TRACE_DCL
260 printf("entity=%lu ", (unsigned long) GET_ENTITY(current_object));
261 printf("%lu ", (unsigned long) current_object);
262 printf("forward decl const current_object = ");
263 trace1(current_object);
264 printf("\n");
265 #endif
266 if (unlikely(err_info != OKAY_NO_ERROR)) {
267 return raise_exception(SYS_MEM_EXCEPTION);
268 } else {
269 return SYS_EMPTY_OBJECT;
270 } /* if */
271 } /* dcl_fwd */
272
273
274
dcl_fwdvar(listType arguments)275 objectType dcl_fwdvar (listType arguments)
276
277 {
278 typeType object_type;
279 objectType name_expr;
280 objectType current_object;
281 errInfoType err_info = OKAY_NO_ERROR;
282
283 /* dcl_fwdvar */
284 isit_type(arg_2(arguments));
285 object_type = take_type(arg_2(arguments));
286 name_expr = arg_4(arguments);
287 #if TRACE_DCL
288 printf("\ndecl var object_type = ");
289 trace1(object_type->match_obj);
290 printf("\ndecl var name_expr = ");
291 trace1(name_expr);
292 printf("\n");
293 #endif
294 grow_stack(&err_info);
295 if (err_info == OKAY_NO_ERROR) {
296 current_object = entername(prog->declaration_root, name_expr, &err_info);
297 if (err_info == OKAY_NO_ERROR) {
298 current_object->type_of = object_type;
299 INIT_CATEGORY_OF_VAR(current_object, FORWARDOBJECT);
300 } /* if */
301 shrink_stack();
302 } /* if */
303 #if TRACE_DCL
304 printf("entity=%lu ", (unsigned long) GET_ENTITY(current_object));
305 printf("%lu ", (unsigned long) current_object);
306 printf("forward decl var current_object = ");
307 trace1(current_object);
308 printf("\n");
309 #endif
310 if (unlikely(err_info != OKAY_NO_ERROR)) {
311 return raise_exception(SYS_MEM_EXCEPTION);
312 } else {
313 return SYS_EMPTY_OBJECT;
314 } /* if */
315 } /* dcl_fwdvar */
316
317
318
dcl_getfunc(listType arguments)319 objectType dcl_getfunc (listType arguments)
320
321 {
322 objectType name_expr;
323 objectType object_found;
324 errInfoType err_info = OKAY_NO_ERROR;
325
326 /* dcl_getfunc */
327 name_expr = arg_2(arguments);
328 #if TRACE_DCL
329 printf("decl const name_expr = ");
330 trace1(name_expr);
331 printf("\n");
332 #endif
333 object_found = search_name(prog->declaration_root, name_expr, &err_info);
334 #if TRACE_DCL
335 printf("entity=%lu ", (unsigned long) GET_ENTITY(object_found));
336 printf("%lu ", (unsigned long) object_found);
337 printf("getfunc object_found = ");
338 trace1(object_found);
339 printf("\n");
340 #endif
341 if (unlikely(err_info != OKAY_NO_ERROR)) {
342 return raise_exception(SYS_MEM_EXCEPTION);
343 } else {
344 return bld_reference_temp(object_found);
345 } /* if */
346 } /* dcl_getfunc */
347
348
349
dcl_getobj(listType arguments)350 objectType dcl_getobj (listType arguments)
351
352 {
353 objectType name_expr;
354 objectType object_found;
355 errInfoType err_info = OKAY_NO_ERROR;
356
357 /* dcl_getobj */
358 name_expr = arg_2(arguments);
359 #if TRACE_DCL
360 printf("decl const name_expr = ");
361 trace1(name_expr);
362 printf("\n");
363 #endif
364 object_found = find_name(prog->declaration_root, name_expr, &err_info);
365 #if TRACE_DCL
366 printf("entity=%lu ", (unsigned long) GET_ENTITY(object_found));
367 printf("%lu ", (unsigned long) object_found);
368 printf("getobj object_found = ");
369 trace1(object_found);
370 printf("\n");
371 #endif
372 if (unlikely(err_info != OKAY_NO_ERROR)) {
373 return raise_exception(SYS_MEM_EXCEPTION);
374 } else {
375 return bld_reference_temp(object_found);
376 } /* if */
377 } /* dcl_getobj */
378
379
380
dcl_global(listType arguments)381 objectType dcl_global (listType arguments)
382
383 {
384 objectType statement;
385 stackType stack_data_backup;
386 stackType stack_current_backup;
387 stackType stack_upward_backup;
388
389 /* dcl_global */
390 statement = arg_2(arguments);
391 stack_data_backup = prog->stack_data;
392 stack_current_backup = prog->stack_current;
393 stack_upward_backup = prog->stack_global->upward;
394 prog->stack_data = prog->stack_global;
395 prog->stack_current = prog->stack_global;
396
397 evaluate(statement);
398
399 prog->stack_data = stack_data_backup;
400 prog->stack_current = stack_current_backup;
401 if (prog->stack_global->upward != NULL) {
402 printf(" *** dcl_global: prog->stack_global->upward != NULL\n");
403 } else {
404 prog->stack_global->upward = stack_upward_backup;
405 } /* if */
406 return SYS_EMPTY_OBJECT;
407 } /* dcl_global */
408
409
410
dcl_in1(listType arguments)411 objectType dcl_in1 (listType arguments)
412
413 {
414 typeType object_type;
415 objectType created_object;
416
417 /* dcl_in1 */
418 isit_type(arg_2(arguments));
419 object_type = take_type(arg_2(arguments));
420 /* printf("decl in1 ");
421 trace1(object_type->match_obj);
422 printf(":\n"); */
423 if (unlikely(!ALLOC_OBJECT(created_object))) {
424 return raise_exception(SYS_MEM_EXCEPTION);
425 } else {
426 created_object->type_of = object_type;
427 created_object->descriptor.property = NULL;
428 created_object->value.objValue = NULL;
429 switch (object_type->in_param_type) {
430 case PARAM_UNDEFINED:
431 err_type(KIND_OF_IN_PARAM_UNDEFINED, object_type);
432 break;
433 case PARAM_VALUE:
434 INIT_CATEGORY_OF_OBJ(created_object, VALUEPARAMOBJECT);
435 break;
436 case PARAM_REF:
437 INIT_CATEGORY_OF_OBJ(created_object, REFPARAMOBJECT);
438 break;
439 } /* switch */
440 /* printf("decl in1 --> %lx ", (unsigned long int) created_object);
441 trace1(created_object);
442 printf(";\n"); */
443 return bld_param_temp(created_object);
444 } /* if */
445 } /* dcl_in1 */
446
447
448
dcl_in2(listType arguments)449 objectType dcl_in2 (listType arguments)
450
451 {
452 typeType object_type;
453 objectType name_expr;
454 errInfoType err_info = OKAY_NO_ERROR;
455 objectType created_object;
456
457 /* dcl_in2 */
458 isit_type(arg_2(arguments));
459 object_type = take_type(arg_2(arguments));
460 name_expr = arg_4(arguments);
461 grow_stack(&err_info);
462 if (err_info == OKAY_NO_ERROR) {
463 /* printf("decl in2 ");
464 trace1(object_type->match_obj);
465 printf(": ");
466 trace1(name_expr);
467 printf(";\n"); */
468 created_object = entername(prog->declaration_root, name_expr, &err_info);
469 if (err_info == OKAY_NO_ERROR) {
470 created_object->type_of = object_type;
471 switch (object_type->in_param_type) {
472 case PARAM_UNDEFINED:
473 err_type(KIND_OF_IN_PARAM_UNDEFINED, object_type);
474 break;
475 case PARAM_VALUE:
476 INIT_CATEGORY_OF_OBJ(created_object, VALUEPARAMOBJECT);
477 break;
478 case PARAM_REF:
479 INIT_CATEGORY_OF_OBJ(created_object, REFPARAMOBJECT);
480 break;
481 } /* switch */
482 /* printf("decl in2 --> %lx ", (unsigned long int) created_object);
483 trace1(created_object);
484 printf(";\n"); */
485 } /* if */
486 shrink_stack();
487 } /* if */
488 if (unlikely(err_info != OKAY_NO_ERROR)) {
489 return raise_exception(SYS_MEM_EXCEPTION);
490 } else {
491 return bld_param_temp(created_object);
492 } /* if */
493 } /* dcl_in2 */
494
495
496
dcl_in1var(listType arguments)497 objectType dcl_in1var (listType arguments)
498
499 {
500 typeType object_type;
501 objectType created_object;
502
503 /* dcl_in1var */
504 isit_type(arg_3(arguments));
505 object_type = take_type(arg_3(arguments));
506 /* printf("decl in1var ");
507 trace1(object_type->match_obj);
508 printf(":\n"); */
509 if (unlikely(!ALLOC_OBJECT(created_object))) {
510 return raise_exception(SYS_MEM_EXCEPTION);
511 } else {
512 created_object->type_of = object_type;
513 created_object->descriptor.property = NULL;
514 INIT_CATEGORY_OF_VAR(created_object, VALUEPARAMOBJECT);
515 created_object->value.objValue = NULL;
516 return bld_param_temp(created_object);
517 } /* if */
518 } /* dcl_in1var */
519
520
521
dcl_in2var(listType arguments)522 objectType dcl_in2var (listType arguments)
523
524 {
525 typeType object_type;
526 objectType name_expr;
527 errInfoType err_info = OKAY_NO_ERROR;
528 objectType created_object;
529
530 /* dcl_in2var */
531 isit_type(arg_3(arguments));
532 object_type = take_type(arg_3(arguments));
533 name_expr = arg_5(arguments);
534 grow_stack(&err_info);
535 if (err_info == OKAY_NO_ERROR) {
536 /* printf("decl in2var ");
537 trace1(object_type->match_obj);
538 printf(": ");
539 trace1(name_expr);
540 printf(";\n"); */
541 created_object = entername(prog->declaration_root, name_expr, &err_info);
542 if (err_info == OKAY_NO_ERROR) {
543 created_object->type_of = object_type;
544 INIT_CATEGORY_OF_VAR(created_object, VALUEPARAMOBJECT);
545 /* printf("decl in2var --> %lx ", (unsigned long int) created_object);
546 trace1(created_object);
547 printf(";\n"); */
548 } /* if */
549 shrink_stack();
550 } /* if */
551 if (unlikely(err_info != OKAY_NO_ERROR)) {
552 return raise_exception(SYS_MEM_EXCEPTION);
553 } else {
554 return bld_param_temp(created_object);
555 } /* if */
556 } /* dcl_in2var */
557
558
559
dcl_inout1(listType arguments)560 objectType dcl_inout1 (listType arguments)
561
562 {
563 typeType object_type;
564 objectType created_object;
565
566 /* dcl_inout1 */
567 isit_type(arg_2(arguments));
568 object_type = take_type(arg_2(arguments));
569 /* printf("decl inout1 ");
570 trace1(object_type->match_obj);
571 printf(":\n"); */
572 if (unlikely(!ALLOC_OBJECT(created_object))) {
573 return raise_exception(SYS_MEM_EXCEPTION);
574 } else {
575 created_object->type_of = object_type;
576 created_object->descriptor.property = NULL;
577 INIT_CATEGORY_OF_VAR(created_object, REFPARAMOBJECT);
578 created_object->value.objValue = NULL;
579 /* printf("dcl_inout1 --> %lx ", (unsigned long int) created_object);
580 trace1(created_object);
581 printf("\n"); */
582 return bld_param_temp(created_object);
583 } /* if */
584 } /* dcl_inout1 */
585
586
587
dcl_inout2(listType arguments)588 objectType dcl_inout2 (listType arguments)
589
590 {
591 typeType object_type;
592 objectType name_expr;
593 errInfoType err_info = OKAY_NO_ERROR;
594 objectType created_object;
595
596 /* dcl_inout2 */
597 isit_type(arg_2(arguments));
598 object_type = take_type(arg_2(arguments));
599 name_expr = arg_4(arguments);
600 grow_stack(&err_info);
601 if (err_info == OKAY_NO_ERROR) {
602 /* printf("decl inout2 ");
603 trace1(object_type->match_obj);
604 printf(": ");
605 trace1(name_expr);
606 printf(";\n"); */
607 created_object = entername(prog->declaration_root, name_expr, &err_info);
608 if (err_info == OKAY_NO_ERROR) {
609 created_object->type_of = object_type;
610 INIT_CATEGORY_OF_VAR(created_object, REFPARAMOBJECT);
611 /* printf("decl inout2 --> %lx ", (unsigned long int) created_object);
612 trace1(created_object);
613 printf(";\n"); */
614 } /* if */
615 shrink_stack();
616 } /* if */
617 if (unlikely(err_info != OKAY_NO_ERROR)) {
618 return raise_exception(SYS_MEM_EXCEPTION);
619 } else {
620 return bld_param_temp(created_object);
621 } /* if */
622 } /* dcl_inout2 */
623
624
625
dcl_param_attr(listType arguments)626 objectType dcl_param_attr (listType arguments)
627
628 {
629 objectType f_param_object;
630 objectType param_object;
631 objectType *f_param_prototype;
632 objectType result;
633
634 /* dcl_param_attr */
635 isit_param(arg_2(arguments));
636 f_param_object = arg_2(arguments);
637 /* printf("decl param attr ");
638 trace1(f_param_object);
639 printf(":\n"); */
640 param_object = take_param(f_param_object);
641 /* printf("decl param attr ");
642 trace1(param_object);
643 printf(":\n"); */
644 if (CATEGORY_OF_OBJ(param_object) == REFPARAMOBJECT && VAR_OBJECT(param_object)) {
645 f_param_prototype = ¶m_object->type_of->inout_f_param_prototype;
646 } else {
647 f_param_prototype = ¶m_object->type_of->other_f_param_prototype;
648 } /* if */
649 if (*f_param_prototype == NULL) {
650 if (unlikely(!ALLOC_OBJECT(result))) {
651 return raise_exception(SYS_MEM_EXCEPTION);
652 } else {
653 result->type_of = NULL;
654 result->descriptor.property = NULL;
655 INIT_CATEGORY_OF_OBJ(result, FORMPARAMOBJECT);
656 result->value.objValue = param_object;
657 } /* if */
658 *f_param_prototype = result;
659 f_param_object->value.objValue = NULL;
660 } else {
661 result = *f_param_prototype;
662 } /* if */
663 /* trace1(param_object);
664 printf("\n");
665 printf("dcl_param_attr --> %lX\n", result);
666 trace1(result);
667 printf("\n"); */
668 return bld_param_temp(result);
669 } /* dcl_param_attr */
670
671
672
dcl_ref1(listType arguments)673 objectType dcl_ref1 (listType arguments)
674
675 {
676 typeType object_type;
677 objectType created_object;
678
679 /* dcl_ref1 */
680 isit_type(arg_2(arguments));
681 object_type = take_type(arg_2(arguments));
682 /* printf("decl ref1 ");
683 trace1(object_type->match_obj);
684 printf(":\n"); */
685 if (unlikely(!ALLOC_OBJECT(created_object))) {
686 return raise_exception(SYS_MEM_EXCEPTION);
687 } else {
688 created_object->type_of = object_type;
689 created_object->descriptor.property = NULL;
690 INIT_CATEGORY_OF_OBJ(created_object, REFPARAMOBJECT);
691 created_object->value.objValue = NULL;
692 /* printf("decl ref1 --> %lx ", (unsigned long int) created_object);
693 trace1(created_object);
694 printf(";\n"); */
695 return bld_param_temp(created_object);
696 } /* if */
697 } /* dcl_ref1 */
698
699
700
dcl_ref2(listType arguments)701 objectType dcl_ref2 (listType arguments)
702
703 {
704 typeType object_type;
705 objectType name_expr;
706 errInfoType err_info = OKAY_NO_ERROR;
707 objectType created_object;
708
709 /* dcl_ref2 */
710 isit_type(arg_2(arguments));
711 object_type = take_type(arg_2(arguments));
712 name_expr = arg_4(arguments);
713 grow_stack(&err_info);
714 if (err_info == OKAY_NO_ERROR) {
715 /* printf("decl ref2 ");
716 trace1(object_type->match_obj);
717 printf(": ");
718 trace1(name_expr);
719 printf(";\n"); */
720 created_object = entername(prog->declaration_root, name_expr, &err_info);
721 if (err_info == OKAY_NO_ERROR) {
722 created_object->type_of = object_type;
723 INIT_CATEGORY_OF_OBJ(created_object, REFPARAMOBJECT);
724 /* printf("decl ref2 --> %lx ", (unsigned long int) created_object);
725 trace1(created_object);
726 printf(";\n"); */
727 } /* if */
728 shrink_stack();
729 } /* if */
730 if (unlikely(err_info != OKAY_NO_ERROR)) {
731 return raise_exception(SYS_MEM_EXCEPTION);
732 } else {
733 return bld_param_temp(created_object);
734 } /* if */
735 } /* dcl_ref2 */
736
737
738
dcl_symb(listType arguments)739 objectType dcl_symb (listType arguments)
740
741 {
742 objectType symb_object;
743
744 /* dcl_symb */
745 symb_object = arg_2(arguments);
746 /* printf("decl symb %lu ", (long unsigned) GET_ENTITY(symb_object));
747 trace1(symb_object);
748 printf(":\n"); */
749 if (HAS_ENTITY(symb_object) &&
750 GET_ENTITY(symb_object)->syobject != NULL) {
751 symb_object = GET_ENTITY(symb_object)->syobject;
752 } /* if */
753 /* printf("decl symb %lu ", (long unsigned) GET_ENTITY(symb_object));
754 trace1(symb_object);
755 printf(":\n"); */
756 return bld_param_temp(symb_object);
757 } /* dcl_symb */
758
759
760
dcl_val1(listType arguments)761 objectType dcl_val1 (listType arguments)
762
763 {
764 typeType object_type;
765 objectType created_object;
766
767 /* dcl_val1 */
768 isit_type(arg_2(arguments));
769 object_type = take_type(arg_2(arguments));
770 /* printf("decl val1 ");
771 trace1(object_type->match_obj);
772 printf(":\n"); */
773 if (unlikely(!ALLOC_OBJECT(created_object))) {
774 return raise_exception(SYS_MEM_EXCEPTION);
775 } else {
776 created_object->type_of = object_type;
777 created_object->descriptor.property = NULL;
778 INIT_CATEGORY_OF_OBJ(created_object, VALUEPARAMOBJECT);
779 created_object->value.objValue = NULL;
780 /* printf("decl val1 --> %lx ", (unsigned long int) created_object);
781 trace1(created_object);
782 printf(";\n"); */
783 return bld_param_temp(created_object);
784 } /* if */
785 } /* dcl_val1 */
786
787
788
dcl_val2(listType arguments)789 objectType dcl_val2 (listType arguments)
790
791 {
792 typeType object_type;
793 objectType name_expr;
794 errInfoType err_info = OKAY_NO_ERROR;
795 objectType created_object;
796
797 /* dcl_val2 */
798 isit_type(arg_2(arguments));
799 object_type = take_type(arg_2(arguments));
800 name_expr = arg_4(arguments);
801 grow_stack(&err_info);
802 if (err_info == OKAY_NO_ERROR) {
803 /* printf("decl val2 ");
804 trace1(object_type->match_obj);
805 printf(": ");
806 trace1(name_expr);
807 printf(";\n"); */
808 created_object = entername(prog->declaration_root, name_expr, &err_info);
809 if (err_info == OKAY_NO_ERROR) {
810 created_object->type_of = object_type;
811 INIT_CATEGORY_OF_OBJ(created_object, VALUEPARAMOBJECT);
812 /* printf("decl val2 --> %lx ", (unsigned long int) created_object);
813 trace1(created_object);
814 printf(";\n"); */
815 } /* if */
816 shrink_stack();
817 } /* if */
818 if (unlikely(err_info != OKAY_NO_ERROR)) {
819 return raise_exception(SYS_MEM_EXCEPTION);
820 } else {
821 return bld_param_temp(created_object);
822 } /* if */
823 } /* dcl_val2 */
824
825
826
dcl_var(listType arguments)827 objectType dcl_var (listType arguments)
828
829 {
830 typeType object_type;
831 objectType name_expr;
832 objectType value_expr;
833 objectType value;
834 objectType matched_value;
835 objectType current_object;
836 errInfoType err_info = OKAY_NO_ERROR;
837
838 /* dcl_var */
839 isit_type(arg_2(arguments));
840 object_type = take_type(arg_2(arguments));
841 name_expr = arg_4(arguments);
842 value_expr = arg_6(arguments);
843 logFunction(printf("dcl_var\n"););
844 #if TRACE_DCL_VAR
845 printf("decl var object_type = ");
846 trace1(object_type->match_obj);
847 printf("\ndecl var name_expr = ");
848 trace1(name_expr);
849 printf("\ndecl var value_expr = ");
850 trace1(value_expr);
851 printf("\n");
852 #endif
853 grow_stack(&err_info);
854 if (err_info == OKAY_NO_ERROR) {
855 if (CATEGORY_OF_OBJ(value_expr) == EXPROBJECT &&
856 value_expr->value.listValue != NULL &&
857 value_expr->value.listValue->next == NULL) {
858 value_expr = value_expr->value.listValue->obj;
859 } /* if */
860 #if TRACE_DCL_VAR
861 printf("decl var value_expr = ");
862 trace1(value_expr);
863 printf("\n");
864 #endif
865 current_object = entername(prog->declaration_root, name_expr, &err_info);
866 value = copy_expression(value_expr, &err_info);
867 if (err_info == OKAY_NO_ERROR) {
868 current_object->type_of = object_type;
869 SET_VAR_FLAG(current_object);
870 #if TRACE_DCL_VAR
871 printf("decl var current_object = ");
872 trace1(current_object);
873 printf("\n");
874 #endif
875 if (CATEGORY_OF_OBJ(value) == EXPROBJECT) {
876 substitute_params(value);
877 if (match_expression(value) != NULL &&
878 (matched_value = match_object(value)) != NULL) {
879 do_create(current_object, matched_value, &err_info);
880 if (err_info == CREATE_ERROR) {
881 err_object(DECL_FAILED, current_object);
882 err_info = OKAY_NO_ERROR;
883 #if TRACE_DCL_VAR
884 printf("*** do_create failed ");
885 prot_list(arguments);
886 printf("\n");
887 #endif
888 } /* if */
889 } else {
890 printf("*** match value failed ");
891 trace1(value);
892 printf("\n");
893 } /* if */
894 } else {
895 do_create(current_object, value, &err_info);
896 if (err_info == CREATE_ERROR) {
897 err_object(DECL_FAILED, current_object);
898 err_info = OKAY_NO_ERROR;
899 #if TRACE_DCL_VAR
900 printf("*** do_create failed ");
901 prot_list(arguments);
902 printf("\n");
903 #endif
904 } /* if */
905 } /* if */
906 free_expression(value);
907 } /* if */
908 shrink_stack();
909 } /* if */
910 logFunction(printf("dcl_var --> err_info=%d\n", err_info););
911 if (unlikely(err_info != OKAY_NO_ERROR)) {
912 return raise_exception(SYS_MEM_EXCEPTION);
913 } else {
914 return SYS_EMPTY_OBJECT;
915 } /* if */
916 } /* dcl_var */
917