-
Notifications
You must be signed in to change notification settings - Fork 4
/
9.c
636 lines (548 loc) · 17.5 KB
/
9.c
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#include "hdr.h"
#include "vars.h"
#include "setprots.h"
#include "errmsgprots.h"
#include "miscprots.h"
#include "smiscprots.h"
#include "nodesprots.h"
#include "dclmapprots.h"
#include "chapprots.h"
void task_spec(Node task_node) /*;task_spec*/
{
Node entries_node, id_node;
int anon;
Symbol task_type_name, t_name, old_kind, entry_sym;
char *id;
Declaredmap entry_list;
Fordeclared fd1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : task_spec");
id_node = N_AST1(task_node);
entries_node = N_AST2(task_node);
#ifdef TBSN
/* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
* DS 9-22-86
*/
opt_specs_node = N_AST3(task_node);
#endif
/*
* If this is a task declaration, an anonymous task type is introduced
* for it. Entry declarations are always attached to the task type.
* TBSL : processing of specifications.
*/
anon = (N_KIND(task_node) == as_task_spec);
id = N_VAL(id_node);
if (anon)
task_type_name =
find_new(strjoin(strjoin("task_type:", id), newat_str()));
else
task_type_name = find_type_name(id_node);
if (task_type_name == symbol_any) return; /* Illegal redeclaration. */
if (anon) {
#ifdef TBSN
XREF lessf:= task_type_name;
#endif
}
old_kind = TYPE_OF(task_type_name); /* may have been private */
NATURE(task_type_name) = na_task_type_spec;
TYPE_OF(task_type_name) = task_type_name;
SIGNATURE(task_type_name) = tup_new(0); /* created by the expander */
root_type(task_type_name) = task_type_name;
initialize_representation_info(task_type_name, TAG_TASK);
/* priv_types is {private, limited_private}; first arg to check_priv_decl
* is one of MISC_TYPE_ATTRIBUTES ...
*/
if (old_kind == symbol_private)
check_priv_decl(TA_PRIVATE, task_type_name);
else if (old_kind == symbol_limited_private)
check_priv_decl(TA_LIMITED_PRIVATE, task_type_name);
if (anon) {
t_name = find_new(id);
NATURE(t_name) = na_task_obj_spec;
TYPE_OF(t_name) = task_type_name;
SIGNATURE(t_name) = (Tuple) 0;
N_UNQ(task_node) = t_name;
}
N_TYPE(task_node) = task_type_name;
newscope(task_type_name); /* introduce new scope */
#ifdef TBSN
prefix := prefix + id + '.'; $ For unique names.
#endif
sem_list(entries_node);
#ifdef TBSN
/* ignore opt_specs_node for now, as N_AST3 used for N_TYPE
* DS 9-22-86
*/
sem_list(opt_specs_node);
#endif
entry_list = DECLARED(scope_name);
popscope();
if (anon) {
/* Attach entry declarations for task object as well, and emit a
* declaration for the task object itself.
*/
SIGNATURE(t_name) = (Tuple) 0;
DECLARED(t_name) = entry_list;
FORDECLARED(id, entry_sym, entry_list, fd1)
/*(for entry = entry_list(id))*/
SCOPE_OF(entry_sym) = t_name;
ENDFORDECLARED(fd1)
}
return;
}
void accept_statement(Node accept_node) /*;accept_statement*/
{
/* This procedure opens a new scope when an ACCEPT statement is seen.
* In the case of an overloaded entry name, it selects the one with
* the matching signature.
*/
int certain;
Symbol task_name, task_type, real_name, entry_name, ix_t;
Set entries;
Tuple formals;
Forset fs1;
Node id_node, indx, body_node;
Node formals_node;
int exists, nat;
char *id, *junk;
Fortup ft1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : accept_statement");
id_node = N_AST1(accept_node);
indx = N_AST2(accept_node);
formals_node = N_AST3(accept_node);
body_node = N_AST4(accept_node);
id = N_VAL(id_node);
formals = get_formals(formals_node, id);
/* Find the task in which the accept statement occurs. The accept
* may of course appear within a block or another accept statement.
*/
exists = FALSE;
FORTUP(task_name = (Symbol), open_scopes, ft1);
nat = NATURE(task_name);
if( nat != na_block && nat != na_entry && nat != na_entry_family) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
certain = exists;
task_type = TYPE_OF(task_name);
if (task_type == (Symbol)0 || NATURE(task_type) != na_task_type) {
errmsg("Accept statements can only appear in tasks","9.5", accept_node);
/* following junk line in SETL not needed here ds 1 nov 84
* entry_name = id;
*/
return;
}
real_name = entry_name = dcl_get(DECLARED(task_name), id);
if (entry_name == (Symbol)0) {
errmsg("Undefined entry name in ACCEPT ", "9.5", id_node);
#ifdef TBSL
-- entry_name is symbol, id is string ds 2-jan-85
entry_name = id; /* For dummy scope. */
#endif
return; /* to Initialize it . */
}
else if (NATURE(entry_name) == na_entry) {
/* Collect all its overloadings and select the one with the
* correct signature.
*/
entries = OVERLOADS(entry_name);
if (indx != OPT_NODE) {
errmsg("invalid index on entry (not entry family)", "9.5", indx);
}
exists = FALSE;
FORSET(entry_name = (Symbol), entries, fs1);
if (same_sig_spec(entry_name, formals)) {
exists = TRUE;
break;
}
ENDFORSET(fs1);
if (!exists) {
errmsg("Entry name in ACCEPT statement does not match any entry" ,
"9.5", id_node);
return;
}
}
else if (NATURE(entry_name) == na_entry_family) {
ix_t = (Symbol) index_type(TYPE_OF(entry_name));
if (indx == OPT_NODE) {
errmsg("Missing index for entry family.", "9.5", accept_node);
}
else {
adasem(indx);
check_type(ix_t, indx);
}
}
else {
errmsg("Invalid entry name in ACCEPT", "9.5", id_node);
return;
}
N_UNQ(id_node) = entry_name;
TO_XREF(entry_name);
reprocess_formals(entry_name, formals_node);
if (in_open_scopes(entry_name )) {
errmsg_l("An accept_statement cannot appear within an ACCEPT for",
" the same entry", "9.5", accept_node);
}
newscope(entry_name);
has_return_stk = tup_with(has_return_stk, (char *)FALSE);
adasem(body_node);
junk = tup_frome(has_return_stk);
popscope();
}
void entry_decl(Node entry_node) /*;entry_decl*/
{
/* An entry declaration is treated like a procedure specification.
* An anonymous type is created for the entry object. This type is
* used by the interpreter to build the environment of an entry.
*/
Symbol entry_sym, entry_type;
Node id_node, formal_list;
Tuple formals;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_decl");
id_node = N_AST1(entry_node);
formal_list = N_AST2(entry_node);
formals = get_formals(formal_list, N_VAL(id_node));
check_out_parameters(formals);
/*entry = chain_overloads(N_VAL(id_node), [na_entry, 'none', formals]); */
entry_sym = chain_overloads(N_VAL(id_node), na_entry, symbol_none,
formals, (Symbol)0, formal_list);
entry_type = anonymous_type();
/*SYMBTAB(entry_type) := [na_entry_former, scope_name, signature(entry)]; */
NATURE(entry_type) = na_entry_former;
TYPE_OF(entry_type) = scope_name;
SIGNATURE(entry_type) = SIGNATURE(entry_sym);
root_type(entry_type) = entry_type;
N_UNQ(id_node) = entry_sym;
N_TYPE(entry_node) = entry_type;
}
void entry_family_decl(Node entry_node) /*;entry_family_decl*/
{
/* An entry family is not an overloadable object. It is constructed
* as an array of entries. An anonymous type is introduced for the entry
* former, just as for an entry declaration, and another is introduced
* for the array representing the family.
*/
Symbol entry_sym, entry_type, family_type;
Symbol opt_range;
Tuple formals, f, tup;
Node id_node, discrete_range, formal_list;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_family_decl");
id_node = N_AST1(entry_node);
discrete_range = N_AST2(entry_node);
formal_list = N_AST3(entry_node);
entry_sym = find_new(N_VAL(id_node));
formals = get_formals(formal_list, N_VAL(id_node));
check_out_parameters(formals);
f = process_formals(entry_sym, formals, TRUE);
entry_type = anonymous_type();
NATURE(entry_type) = na_entry_former;
TYPE_OF(entry_type) = scope_name;
SIGNATURE(entry_type) = f;
root_type(entry_type) = entry_type;
adasem(discrete_range);
opt_range = make_index(discrete_range);
family_type = anonymous_type();
/* SYMBTAB(family_type) =
* [na_array, family_type, [[opt_range], entry_type]];
*/
NATURE(family_type) = na_array;
TYPE_OF(family_type) = family_type;
tup = tup_new(2);
tup[1] = (char *) tup_new1((char *) opt_range);
tup[2] = (char *) entry_type;
SIGNATURE(family_type) = (Tuple) tup;
root_type(family_type) = family_type;
/* SYMBTAB(entry) = [na_entry_family, family_type, f]; */
NATURE(entry_sym) = na_entry_family;
TYPE_OF(entry_sym) = family_type;
SIGNATURE(entry_sym) = f;
formal_decl_tree(entry_sym) = (Symbol) formal_list;
N_UNQ(id_node) = entry_sym;
N_TYPE(entry_node) = family_type;
}
void entry_call(Node node) /*;entry_call*/
{
/* process an entry call. obj_node below is the entry name: either a se-
* lected or an indexed expression.
*/
Symbol range_typ, entry_sym;
Node obj_node, arg_list_node;
Tuple arg_list;
Node task_node, index_node, entry_node;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : entry_call");
obj_node = N_AST1(node);
arg_list_node = N_AST2(node);
arg_list = N_LIST(arg_list_node);
find_entry_name(obj_node); /* Normalize entry name*/
task_node = N_AST1(obj_node);
entry_node = N_AST2(obj_node);
if (entry_node == OPT_NODE) return; /* previous error. */
if (N_KIND(obj_node) == as_entry_family_name) {
entry_sym = N_UNQ(entry_node);
range_typ = (Symbol) index_type(TYPE_OF(entry_sym));
index_node = N_AST3(obj_node);
if (index_node == OPT_NODE) {
/* Case of a call to a parameterless family. The formals list
* is actually the index expression. Verify its size.
*/
if (tup_size(arg_list) != 1) {
errmsg("Call to member of entry family requires one index",
"9.5, 3.6.1", obj_node);
return;
}
else {
index_node = (Node) arg_list[1];
N_AST3(obj_node) = index_node;
arg_list_node = node_new(as_list);
N_LIST(arg_list_node) = tup_new(0);
N_AST2(node) = arg_list_node;
}
}
check_type(range_typ, index_node);
/* process as usual call.*/
N_NAMES(obj_node) = set_new1((char *) entry_sym);
check_type(TYPE_OF(entry_sym), node);
N_AST3(obj_node) = index_node; /* restore index */
N_KIND(obj_node) = as_entry_name; /* common processing after this */
}
else { /* Simple entry.*/
check_type(symbol_none, node); /* as for a procedure call */
entry_sym = N_UNQ(entry_node);
N_AST3(obj_node) = OPT_NODE; /* discard N_NAMES */
}
/* Having resolved the call, use the unique entry name to complete the
* resolution of the task name itself.
*/
if (entry_sym != (Symbol)0)
complete_task_name(task_node, TYPE_OF(SCOPE_OF(entry_sym)));
return;
}
void check_entry_call(Node stat_node) /*;check_entry_call*/
{
/* Verify that the call in a timed entry call or a conditional entry call
* is indeed a call to an entry, and not to a procedure.
*/
adasem(stat_node);
if (N_KIND(stat_node) == as_call) {
errmsg("context requires entry name ", "9.7.2, 7.3", stat_node);
}
}
void find_entry_name(Node obj_node) /*;find_entry_name*/
{
/* Find the name of an entry or entry family, given by a qualified and
* (in the case of a family) indexed expression. This differs from other
* cases of name resolution in that the name of the task containing the
* entry can be given by an expression that must also be resolved.
* This procedure is also called to validate the argument of the COUNT
* attribute; this attribute can only be used within the task body, in
* which the entry need not be named as a selected component. An entry
* name will then be seen as an overloaded identifier. The task name is
* the scope of the entry.
* An entry family name is built as a triple [task_node, entry_node, index]
* An entry name is built as a pair [task_node, entry_name]. In addition,
* the N_NAMES field is defined in the case of entries, which can be over-
* loaded.
*/
Node index_list_node, task_node, entry_node, index_node;
Tuple index_list;
Symbol obj, task_name, t, e, sym;
Set entries, task_types, entry_names;
Forset fs1, fs2;
char *entry_id;
int exists, is_family;
if (cdebug2 > 3 ) TO_ERRFILE("AT PROC : find_entry_name");
if (N_KIND(obj_node) == as_simple_name) {
if (N_OVERLOADED(obj_node) ) {
entries = N_NAMES(obj_node);
task_name = SCOPE_OF((Symbol)set_arb( entries));
if (!is_task_type(TYPE_OF(task_name))) {
errmsg("Invalid entry name", "9.5", obj_node);
entry_node = OPT_NODE;
}
else {
entry_node = copy_node(obj_node);
}
task_node = node_new(as_simple_name);
N_UNQ(task_node) = task_name;
N_VAL(task_node) = (char *) original_name(task_name);
copy_span(obj_node, task_node);
index_node = OPT_NODE;
}
else if (NATURE((obj = N_UNQ(obj_node))) == na_entry_family) {
/* Member of entry family, with index missing. */
errmsg("Missing index in name of member of entry family",
"9.5", obj_node);
entry_node = OPT_NODE;
}
}
else if (N_KIND(obj_node) == as_selector) { /* selected_component*/
task_node = N_AST1(obj_node);
entry_node = N_AST2(obj_node);
index_node = OPT_NODE;
}
else { /* case of entry family. */
entry_node = N_AST1(obj_node);
index_list_node = N_AST2(obj_node);
if (N_KIND(entry_node) == as_simple_name) {
/* Entry family named in task body. Get enclosing task name.*/
task_node = node_new(as_simple_name);
task_name = SCOPE_OF(N_UNQ(entry_node));
N_UNQ(task_node) = task_name;
N_VAL(task_node) = (char *) original_name(task_name);
copy_span(obj_node, task_node);
}
else {/* Name is selected component. */
task_node = N_AST1(entry_node);
entry_node = N_AST2(entry_node);
}
index_list = N_LIST(index_list_node);
if (tup_size(index_list) != 1) {
errmsg("Member of entry family requires a single index ",
"9.5, 3.6.1", obj_node);
entry_node = OPT_NODE;
}
index_node = (Node) index_list[1];/* In any case. */
}
if (entry_node != OPT_NODE) { /* no previous error*/
valid_task_name(task_node);
task_types = N_PTYPES(task_node);
if (set_size(task_types) == 0) /* prefix is not a task*/
entry_node = OPT_NODE;
}
else {
task_node = OPT_NODE;
task_types = set_new(0);
}
entry_names = set_new(0);
entry_id = (char *) N_VAL(entry_node);
is_family = FALSE;
FORSET(t = (Symbol), task_types, fs1);
if (is_access(t)) t = (Symbol) designated_type(t);
e = dcl_get(DECLARED(t), entry_id);
if (e != (Symbol)0) {
if (NATURE(e) == na_entry) {
FORSET(sym = (Symbol), OVERLOADS(e), fs2);
entry_names = set_with(entry_names, (char *) sym);
ENDFORSET(fs2);
}
else { /* name of entry family*/
entry_names = set_with(entry_names, (char *) e);
is_family = TRUE;
}
}
ENDFORSET(fs1);
if (set_size(entry_names) == 0 && entry_node != OPT_NODE ) {
errmsg("Undefined entry name in task : ", "9.5", obj_node);
entry_node = OPT_NODE;
}
else {
exists = FALSE;
if (set_size(entry_names) > 1 ) {
exists = FALSE;
FORSET(e = (Symbol), entry_names, fs2);
if (NATURE(e) == na_entry_family ) {
exists = TRUE;
break;
}
ENDFORSET(fs2);
}
if (exists) {
errmsg_id("ambiguous entry family name: %", e , "9.5", obj_node);
/* entry is undefined, this is a guess (gs sep 20) */
entry_node = OPT_NODE;
}
else if (entry_node != OPT_NODE) {
if (is_family) {
N_KIND(obj_node) = as_entry_family_name;
N_UNQ(entry_node) = (Symbol)set_arb(entry_names);
N_AST3(obj_node) = index_node;
}
else {
N_KIND(obj_node) = as_entry_name;
N_NAMES(obj_node) = entry_names;
if (index_node != OPT_NODE ) {
errmsg_id("invalid index. % is not an entry family",
(Symbol) set_arb(entry_names), "9.5", obj_node);
}
}
}
}
N_AST1(obj_node) = task_node;
N_AST2(obj_node) = entry_node;
}
void terminate_statement(Node node) /*;terminate_statement*/
{
/* A terminate alternative is annotated with the nesting level of the
* statement, to simplify the retrieval of the task environment.
*/
int certain, exists, i, out_depth, j, blktyp;
Fortup ft1;
Symbol scope;
exists = TRUE;
FORTUPI(scope = (Symbol), open_scopes, i, ft1);
if (NATURE(scope) == na_task_obj || NATURE(scope) == na_task_type) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
certain = exists;
if (!certain) {
errmsg("Invalid context for TERMINATE alternative", "9.7.1", node);
i = 1;
}
/* Loops and handlers are scopes for syntactic purposes, but not at run-
* time. Remove them from depth count.
*/
out_depth = i - 1;
for (j = i; j > 0; j--) {
scope = (Symbol) open_scopes[j];
blktyp = (int) OVERLOADS(scope);
if (blktyp == BLOCK_LOOP || blktyp == BLOCK_HANDLER)
out_depth -= 1;
}
N_VAL(node) = (char *) out_depth;
}
void abort_statement(Node node) /*;abort_statement*/
{
Node name_node;
Fortup ft1;
Symbol task_obj;
Set task_types;
Symbol t;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : abort_statement");
FORTUP(name_node = (Node), N_LIST(node), ft1);
adasem(name_node);
find_old(name_node);
valid_task_name(name_node);
task_types = N_PTYPES(name_node);
if (set_size(task_types) == 0) /* Previous error*/
continue;
else if (!is_task_type( (t = (Symbol)set_arb (task_types), t) ) ) {
/* Access type not valid here.*/
errmsg(" expect task name is ABORT statement", "9.10", name_node);
continue;
}
else
resolve2(name_node, t);
if (N_KIND(name_node) == as_simple_name
&& NATURE(task_obj = N_UNQ(name_node)) == na_task_type ) {
/* This is a reference to the task currently executing the body.
* replace the name of the task type by its run-time identity.
*/
if (in_open_scopes(task_obj))
N_UNQ(name_node) = dcl_get(DECLARED(task_obj), "current_task");
else {
errmsg("Invalid task type in ABORT statement", "9.10",
name_node);
}
}
ENDFORTUP(ft1);
}