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
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ S C I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
package body Sem_SCIL is
----------------------
-- Adjust_SCIL_Node --
----------------------
procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is
SCIL_Node : Node_Id;
begin
pragma Assert (Generate_SCIL);
-- Check cases in which no action is required. Currently the only SCIL
-- nodes that may require adjustment are those of dispatching calls
-- internally generated by the frontend.
if Comes_From_Source (Old_Node)
or else not
Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)
then
return;
-- Conditional expression associated with equality operator. Old_Node
-- may be part of the expansion of the predefined equality operator of
-- a tagged type and hence we need to check if it has a SCIL dispatching
-- node that needs adjustment.
elsif Nkind (Old_Node) = N_Conditional_Expression
and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq
or else
(Nkind (Original_Node (Old_Node)) = N_Function_Call
and then Chars (Name (Original_Node (Old_Node))) =
Name_Op_Eq))
then
null;
-- Type conversions may involve dispatching calls to functions whose
-- associated SCIL dispatching node needs adjustment.
elsif Nkind_In (Old_Node, N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
null;
-- Relocated subprogram call
elsif Nkind (Old_Node) = Nkind (New_Node)
and then Original_Node (Old_Node) = Original_Node (New_Node)
then
null;
else
return;
end if;
-- Search for the SCIL node and update it (if found)
SCIL_Node := Find_SCIL_Node (Old_Node);
if Present (SCIL_Node) then
Set_SCIL_Related_Node (SCIL_Node, New_Node);
end if;
end Adjust_SCIL_Node;
---------------------
-- Check_SCIL_Node --
---------------------
function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
Ctrl_Tag : Node_Id;
Ctrl_Typ : Entity_Id;
begin
if Nkind (N) = N_SCIL_Membership_Test then
-- Check contents of the boolean expression associated with the
-- membership test.
pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier
and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);
-- Check the entity identifier of the associated tagged type (that
-- is, in testing for membership in T'Class, the entity id of the
-- specific type T).
-- Note: When the SCIL node is generated the private and full-view
-- of the tagged types may have been swapped and hence the node
-- referenced by attribute SCIL_Entity may be the private view.
-- Therefore, in order to uniformily locate the full-view we use
-- attribute Underlying_Type.
pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));
-- Interface types are unsupported
pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));
-- Check the decoration of the expression that denotes the tag value
-- being tested
Ctrl_Tag := SCIL_Tag_Value (N);
case Nkind (Ctrl_Tag) is
-- For class-wide membership tests the SCIL tag value is the tag
-- of the tested object (i.e. Obj.Tag).
when N_Selected_Component =>
pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
null;
when others =>
pragma Assert (False);
null;
end case;
return Skip;
elsif Nkind (N) = N_SCIL_Dispatching_Call then
Ctrl_Tag := SCIL_Controlling_Tag (N);
-- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
-- subprogram calls.
if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
N_Procedure_Call_Statement)
then
pragma Assert (False);
raise Program_Error;
-- In simple cases the controlling tag is the tag of the controlling
-- argument (i.e. Obj.Tag).
elsif Nkind (Ctrl_Tag) = N_Selected_Component then
Ctrl_Typ := Etype (Ctrl_Tag);
-- Interface types are unsupported
if Is_Interface (Ctrl_Typ)
or else (RTE_Available (RE_Interface_Tag)
and then Ctrl_Typ = RTE (RE_Interface_Tag))
then
null;
else
pragma Assert (Ctrl_Typ = RTE (RE_Tag));
null;
end if;
-- When the controlling tag of a dispatching call is an identifier
-- the SCIL_Controlling_Tag attribute references the corresponding
-- object or parameter declaration. Interface types are still
-- unsupported.
elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
N_Parameter_Specification)
then
Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
-- Interface types are unsupported.
if Is_Interface (Ctrl_Typ)
or else (RTE_Available (RE_Interface_Tag)
and then Ctrl_Typ = RTE (RE_Interface_Tag))
or else (Is_Access_Type (Ctrl_Typ)
and then
Is_Interface
(Available_View
(Base_Type (Designated_Type (Ctrl_Typ)))))
then
null;
else
pragma Assert
(Ctrl_Typ = RTE (RE_Tag)
or else
(Is_Access_Type (Ctrl_Typ)
and then Available_View
(Base_Type (Designated_Type (Ctrl_Typ))) =
RTE (RE_Tag)));
null;
end if;
-- Interface types are unsupported
elsif Is_Interface (Etype (Ctrl_Tag)) then
null;
else
pragma Assert (False);
raise Program_Error;
end if;
return Skip;
-- Node is not N_SCIL_Dispatching_Call
else
return OK;
end if;
end Check_SCIL_Node;
--------------------
-- Find_SCIL_Node --
--------------------
function Find_SCIL_Node (Node : Node_Id) return Node_Id is
Found_Node : Node_Id;
-- This variable stores the last node found by the nested subprogram
-- Find_SCIL_Node.
function Find_SCIL_Node (L : List_Id) return Boolean;
-- Searches in list L for a SCIL node associated with a dispatching call
-- whose SCIL_Related_Node is Node. If found returns true and stores the
-- SCIL node in Found_Node; otherwise returns False and sets Found_Node
-- to Empty.
--------------------
-- Find_SCIL_Node --
--------------------
function Find_SCIL_Node (L : List_Id) return Boolean is
N : Node_Id;
begin
N := First (L);
while Present (N) loop
if Nkind (N) in N_SCIL_Node
and then SCIL_Related_Node (N) = Node
then
Found_Node := N;
return True;
end if;
Next (N);
end loop;
Found_Node := Empty;
return False;
end Find_SCIL_Node;
-- Local variables
P : Node_Id;
-- Start of processing for Find_SCIL_Node
begin
pragma Assert (Generate_SCIL);
-- Search for the SCIL node in list associated with a transient scope
if Scope_Is_Transient then
declare
SE : Scope_Stack_Entry
renames Scope_Stack.Table (Scope_Stack.Last);
begin
if SE.Is_Transient
and then Present (SE.Actions_To_Be_Wrapped_Before)
and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)
then
return Found_Node;
end if;
end;
end if;
-- Otherwise climb up the tree searching for the SCIL node analyzing
-- all the lists in which Insert_Actions may have inserted it
P := Node;
while Present (P) loop
case Nkind (P) is
-- Actions associated with AND THEN or OR ELSE
when N_Short_Circuit =>
if Present (Actions (P))
and then Find_SCIL_Node (Actions (P))
then
return Found_Node;
end if;
-- Actions of conditional expressions
when N_Conditional_Expression =>
if (Present (Then_Actions (P))
and then Find_SCIL_Node (Actions (P)))
or else
(Present (Else_Actions (P))
and then Find_SCIL_Node (Else_Actions (P)))
then
return Found_Node;
end if;
-- Actions in handled sequence of statements
when
N_Handled_Sequence_Of_Statements =>
if Find_SCIL_Node (Statements (P)) then
return Found_Node;
end if;
-- Conditions of while expression or elsif.
when N_Iteration_Scheme |
N_Elsif_Part
=>
if Present (Condition_Actions (P))
and then Find_SCIL_Node (Condition_Actions (P))
then
return Found_Node;
end if;
-- Statements, declarations, pragmas, representation clauses
when
-- Statements
N_Procedure_Call_Statement |
N_Statement_Other_Than_Procedure_Call |
-- Pragmas
N_Pragma |
-- Representation_Clause
N_At_Clause |
N_Attribute_Definition_Clause |
N_Enumeration_Representation_Clause |
N_Record_Representation_Clause |
-- Declarations
N_Abstract_Subprogram_Declaration |
N_Entry_Body |
N_Exception_Declaration |
N_Exception_Renaming_Declaration |
N_Formal_Abstract_Subprogram_Declaration |
N_Formal_Concrete_Subprogram_Declaration |
N_Formal_Object_Declaration |
N_Formal_Type_Declaration |
N_Full_Type_Declaration |
N_Function_Instantiation |
N_Generic_Function_Renaming_Declaration |
N_Generic_Package_Declaration |
N_Generic_Package_Renaming_Declaration |
N_Generic_Procedure_Renaming_Declaration |
N_Generic_Subprogram_Declaration |
N_Implicit_Label_Declaration |
N_Incomplete_Type_Declaration |
N_Number_Declaration |
N_Object_Declaration |
N_Object_Renaming_Declaration |
N_Package_Body |
N_Package_Body_Stub |
N_Package_Declaration |
N_Package_Instantiation |
N_Package_Renaming_Declaration |
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Procedure_Instantiation |
N_Protected_Body |
N_Protected_Body_Stub |
N_Protected_Type_Declaration |
N_Single_Task_Declaration |
N_Subprogram_Body |
N_Subprogram_Body_Stub |
N_Subprogram_Declaration |
N_Subprogram_Renaming_Declaration |
N_Subtype_Declaration |
N_Task_Body |
N_Task_Body_Stub |
N_Task_Type_Declaration |
-- Freeze entity behaves like a declaration or statement
N_Freeze_Entity
=>
-- Do not search here if the item is not a list member
if not Is_List_Member (P) then
null;
-- Do not search if parent of P is an N_Component_Association
-- node (i.e. we are in the context of an N_Aggregate or
-- N_Extension_Aggregate node). In this case the node should
-- have been added before the entire aggregate.
elsif Nkind (Parent (P)) = N_Component_Association then
null;
-- Do not search if the parent of P is either an N_Variant
-- node or an N_Record_Definition node. In this case the node
-- should have been added before the entire record.
elsif Nkind (Parent (P)) = N_Variant
or else Nkind (Parent (P)) = N_Record_Definition
then
null;
-- Otherwise search it in the list containing this node
elsif Find_SCIL_Node (List_Containing (P)) then
return Found_Node;
end if;
-- A special case, N_Raise_xxx_Error can act either as a statement
-- or a subexpression. We diferentiate them by looking at the
-- Etype. It is set to Standard_Void_Type in the statement case.
when
N_Raise_xxx_Error =>
if Etype (P) = Standard_Void_Type then
if Is_List_Member (P)
and then Find_SCIL_Node (List_Containing (P))
then
return Found_Node;
end if;
-- In the subexpression case, keep climbing
else
null;
end if;
-- If a component association appears within a loop created for
-- an array aggregate, check if the SCIL node was added to the
-- the list of nodes attached to the association.
when
N_Component_Association =>
if Nkind (Parent (P)) = N_Aggregate
and then Present (Loop_Actions (P))
and then Find_SCIL_Node (Loop_Actions (P))
then
return Found_Node;
end if;
-- Another special case, an attribute denoting a procedure call
when
N_Attribute_Reference =>
if Is_Procedure_Attribute_Name (Attribute_Name (P))
and then Find_SCIL_Node (List_Containing (P))
then
return Found_Node;
-- In the subexpression case, keep climbing
else
null;
end if;
-- SCIL nodes do not have subtrees and hence they can never be
-- found climbing tree
when
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init
=>
pragma Assert (False);
raise Program_Error;
-- For all other node types, keep climbing tree
when
N_Abortable_Part |
N_Accept_Alternative |
N_Access_Definition |
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |
N_Compilation_Unit_Aux |
N_Component_Clause |
N_Component_Declaration |
N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Decimal_Fixed_Point_Definition |
N_Defining_Character_Literal |
N_Defining_Identifier |
N_Defining_Operator_Symbol |
N_Defining_Program_Unit_Name |
N_Delay_Alternative |
N_Delta_Constraint |
N_Derived_Type_Definition |
N_Designator |
N_Digits_Constraint |
N_Discriminant_Association |
N_Discriminant_Specification |
N_Empty |
N_Entry_Body_Formal_Part |
N_Entry_Call_Alternative |
N_Entry_Declaration |
N_Entry_Index_Specification |
N_Enumeration_Type_Definition |
N_Error |
N_Exception_Handler |
N_Expanded_Name |
N_Explicit_Dereference |
N_Extension_Aggregate |
N_Floating_Point_Definition |
N_Formal_Decimal_Fixed_Point_Definition |
N_Formal_Derived_Type_Definition |
N_Formal_Discrete_Type_Definition |
N_Formal_Floating_Point_Definition |
N_Formal_Modular_Type_Definition |
N_Formal_Ordinary_Fixed_Point_Definition |
N_Formal_Package_Declaration |
N_Formal_Private_Type_Definition |
N_Formal_Signed_Integer_Type_Definition |
N_Function_Call |
N_Function_Specification |
N_Generic_Association |
N_Identifier |
N_In |
N_Index_Or_Discriminant_Constraint |
N_Indexed_Component |
N_Integer_Literal |
N_Itype_Reference |
N_Label |
N_Loop_Parameter_Specification |
N_Mod_Clause |
N_Modular_Type_Definition |
N_Not_In |
N_Null |
N_Op_Abs |
N_Op_Add |
N_Op_And |
N_Op_Concat |
N_Op_Divide |
N_Op_Eq |
N_Op_Expon |
N_Op_Ge |
N_Op_Gt |
N_Op_Le |
N_Op_Lt |
N_Op_Minus |
N_Op_Mod |
N_Op_Multiply |
N_Op_Ne |
N_Op_Not |
N_Op_Or |
N_Op_Plus |
N_Op_Rem |
N_Op_Rotate_Left |
N_Op_Rotate_Right |
N_Op_Shift_Left |
N_Op_Shift_Right |
N_Op_Shift_Right_Arithmetic |
N_Op_Subtract |
N_Op_Xor |
N_Operator_Symbol |
N_Ordinary_Fixed_Point_Definition |
N_Others_Choice |
N_Package_Specification |
N_Parameter_Association |
N_Parameter_Specification |
N_Pop_Constraint_Error_Label |
N_Pop_Program_Error_Label |
N_Pop_Storage_Error_Label |
N_Pragma_Argument_Association |
N_Procedure_Specification |
N_Protected_Definition |
N_Push_Constraint_Error_Label |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
N_Real_Range_Specification |
N_Record_Definition |
N_Reference |
N_Selected_Component |
N_Signed_Integer_Type_Definition |
N_Single_Protected_Declaration |
N_Slice |
N_String_Literal |
N_Subprogram_Info |
N_Subtype_Indication |
N_Subunit |
N_Task_Definition |
N_Terminate_Alternative |
N_Triggering_Alternative |
N_Type_Conversion |
N_Unchecked_Expression |
N_Unchecked_Type_Conversion |
N_Unconstrained_Array_Definition |
N_Unused_At_End |
N_Unused_At_Start |
N_Use_Package_Clause |
N_Use_Type_Clause |
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
N_With_Clause
=>
null;
end case;
-- If we fall through above tests, keep climbing tree
if Nkind (Parent (P)) = N_Subunit then
-- This is the proper body corresponding to a stub. Insertion done
-- at the point of the stub, which is in the declarative part of
-- the parent unit.
P := Corresponding_Stub (Parent (P));
else
P := Parent (P);
end if;
end loop;
-- SCIL node not found
return Empty;
end Find_SCIL_Node;
-------------------------
-- First_Non_SCIL_Node --
-------------------------
function First_Non_SCIL_Node (L : List_Id) return Node_Id is
N : Node_Id;
begin
N := First (L);
while Nkind (N) in N_SCIL_Node loop
Next (N);
end loop;
return N;
end First_Non_SCIL_Node;
------------------------
-- Next_Non_SCIL_Node --
------------------------
function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
Aux_N : Node_Id;
begin
Aux_N := Next (N);
while Nkind (Aux_N) in N_SCIL_Node loop
Next (Aux_N);
end loop;
return Aux_N;
end Next_Non_SCIL_Node;
end Sem_SCIL;
|