fixing pr42337
[official-gcc.git] / gcc / ada / sem_scil.adb
blob5adf803fc703e61c231697d29a2f66abce32502a
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ S C I L --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2009, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Einfo; use Einfo;
27 with Namet; use Namet;
28 with Nlists; use Nlists;
29 with Opt; use Opt;
30 with Rtsfind; use Rtsfind;
31 with Sem; use Sem;
32 with Sem_Aux; use Sem_Aux;
33 with Sem_Util; use Sem_Util;
34 with Sinfo; use Sinfo;
35 with Snames; use Snames;
36 with Stand; use Stand;
38 package body Sem_SCIL is
40 ----------------------
41 -- Adjust_SCIL_Node --
42 ----------------------
44 procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is
45 SCIL_Node : Node_Id;
47 begin
48 pragma Assert (Generate_SCIL);
50 -- Check cases in which no action is required. Currently the only SCIL
51 -- nodes that may require adjustment are those of dispatching calls
52 -- internally generated by the frontend.
54 if Comes_From_Source (Old_Node)
55 or else not
56 Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)
57 then
58 return;
60 -- Conditional expression associated with equality operator. Old_Node
61 -- may be part of the expansion of the predefined equality operator of
62 -- a tagged type and hence we need to check if it has a SCIL dispatching
63 -- node that needs adjustment.
65 elsif Nkind (Old_Node) = N_Conditional_Expression
66 and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq
67 or else
68 (Nkind (Original_Node (Old_Node)) = N_Function_Call
69 and then Chars (Name (Original_Node (Old_Node))) =
70 Name_Op_Eq))
71 then
72 null;
74 -- Type conversions may involve dispatching calls to functions whose
75 -- associated SCIL dispatching node needs adjustment.
77 elsif Nkind_In (Old_Node, N_Type_Conversion,
78 N_Unchecked_Type_Conversion)
79 then
80 null;
82 -- Relocated subprogram call
84 elsif Nkind (Old_Node) = Nkind (New_Node)
85 and then Original_Node (Old_Node) = Original_Node (New_Node)
86 then
87 null;
89 else
90 return;
91 end if;
93 -- Search for the SCIL node and update it (if found)
95 SCIL_Node := Find_SCIL_Node (Old_Node);
97 if Present (SCIL_Node) then
98 Set_SCIL_Related_Node (SCIL_Node, New_Node);
99 end if;
100 end Adjust_SCIL_Node;
102 ---------------------
103 -- Check_SCIL_Node --
104 ---------------------
106 function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
107 Ctrl_Tag : Node_Id;
108 Ctrl_Typ : Entity_Id;
110 begin
111 if Nkind (N) = N_SCIL_Membership_Test then
113 -- Check contents of the boolean expression associated with the
114 -- membership test.
116 pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier
117 and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);
119 -- Check the entity identifier of the associated tagged type (that
120 -- is, in testing for membership in T'Class, the entity id of the
121 -- specific type T).
123 -- Note: When the SCIL node is generated the private and full-view
124 -- of the tagged types may have been swapped and hence the node
125 -- referenced by attribute SCIL_Entity may be the private view.
126 -- Therefore, in order to uniformily locate the full-view we use
127 -- attribute Underlying_Type.
129 pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));
131 -- Interface types are unsupported
133 pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));
135 -- Check the decoration of the expression that denotes the tag value
136 -- being tested
138 Ctrl_Tag := SCIL_Tag_Value (N);
140 case Nkind (Ctrl_Tag) is
142 -- For class-wide membership tests the SCIL tag value is the tag
143 -- of the tested object (i.e. Obj.Tag).
145 when N_Selected_Component =>
146 pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
147 null;
149 when others =>
150 pragma Assert (False);
151 null;
153 end case;
155 return Skip;
157 elsif Nkind (N) = N_SCIL_Dispatching_Call then
158 Ctrl_Tag := SCIL_Controlling_Tag (N);
160 -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
161 -- subprogram calls.
163 if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
164 N_Procedure_Call_Statement)
165 then
166 pragma Assert (False);
167 raise Program_Error;
169 -- In simple cases the controlling tag is the tag of the controlling
170 -- argument (i.e. Obj.Tag).
172 elsif Nkind (Ctrl_Tag) = N_Selected_Component then
173 Ctrl_Typ := Etype (Ctrl_Tag);
175 -- Interface types are unsupported
177 if Is_Interface (Ctrl_Typ)
178 or else (RTE_Available (RE_Interface_Tag)
179 and then Ctrl_Typ = RTE (RE_Interface_Tag))
180 then
181 null;
183 else
184 pragma Assert (Ctrl_Typ = RTE (RE_Tag));
185 null;
186 end if;
188 -- When the controlling tag of a dispatching call is an identifier
189 -- the SCIL_Controlling_Tag attribute references the corresponding
190 -- object or parameter declaration. Interface types are still
191 -- unsupported.
193 elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
194 N_Parameter_Specification)
195 then
196 Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
198 -- Interface types are unsupported.
200 if Is_Interface (Ctrl_Typ)
201 or else (RTE_Available (RE_Interface_Tag)
202 and then Ctrl_Typ = RTE (RE_Interface_Tag))
203 or else (Is_Access_Type (Ctrl_Typ)
204 and then
205 Is_Interface
206 (Available_View
207 (Base_Type (Designated_Type (Ctrl_Typ)))))
208 then
209 null;
211 else
212 pragma Assert
213 (Ctrl_Typ = RTE (RE_Tag)
214 or else
215 (Is_Access_Type (Ctrl_Typ)
216 and then Available_View
217 (Base_Type (Designated_Type (Ctrl_Typ))) =
218 RTE (RE_Tag)));
219 null;
220 end if;
222 -- Interface types are unsupported
224 elsif Is_Interface (Etype (Ctrl_Tag)) then
225 null;
227 else
228 pragma Assert (False);
229 raise Program_Error;
230 end if;
232 return Skip;
234 -- Node is not N_SCIL_Dispatching_Call
236 else
237 return OK;
238 end if;
239 end Check_SCIL_Node;
241 --------------------
242 -- Find_SCIL_Node --
243 --------------------
245 function Find_SCIL_Node (Node : Node_Id) return Node_Id is
246 Found_Node : Node_Id;
247 -- This variable stores the last node found by the nested subprogram
248 -- Find_SCIL_Node.
250 function Find_SCIL_Node (L : List_Id) return Boolean;
251 -- Searches in list L for a SCIL node associated with a dispatching call
252 -- whose SCIL_Related_Node is Node. If found returns true and stores the
253 -- SCIL node in Found_Node; otherwise returns False and sets Found_Node
254 -- to Empty.
256 --------------------
257 -- Find_SCIL_Node --
258 --------------------
260 function Find_SCIL_Node (L : List_Id) return Boolean is
261 N : Node_Id;
263 begin
264 N := First (L);
265 while Present (N) loop
266 if Nkind (N) in N_SCIL_Node
267 and then SCIL_Related_Node (N) = Node
268 then
269 Found_Node := N;
270 return True;
271 end if;
273 Next (N);
274 end loop;
276 Found_Node := Empty;
277 return False;
278 end Find_SCIL_Node;
280 -- Local variables
282 P : Node_Id;
284 -- Start of processing for Find_SCIL_Node
286 begin
287 pragma Assert (Generate_SCIL);
289 -- Search for the SCIL node in list associated with a transient scope
291 if Scope_Is_Transient then
292 declare
293 SE : Scope_Stack_Entry
294 renames Scope_Stack.Table (Scope_Stack.Last);
295 begin
296 if SE.Is_Transient
297 and then Present (SE.Actions_To_Be_Wrapped_Before)
298 and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)
299 then
300 return Found_Node;
301 end if;
302 end;
303 end if;
305 -- Otherwise climb up the tree searching for the SCIL node analyzing
306 -- all the lists in which Insert_Actions may have inserted it
308 P := Node;
309 while Present (P) loop
310 case Nkind (P) is
312 -- Actions associated with AND THEN or OR ELSE
314 when N_Short_Circuit =>
315 if Present (Actions (P))
316 and then Find_SCIL_Node (Actions (P))
317 then
318 return Found_Node;
319 end if;
321 -- Actions of conditional expressions
323 when N_Conditional_Expression =>
324 if (Present (Then_Actions (P))
325 and then Find_SCIL_Node (Actions (P)))
326 or else
327 (Present (Else_Actions (P))
328 and then Find_SCIL_Node (Else_Actions (P)))
329 then
330 return Found_Node;
331 end if;
333 -- Actions in handled sequence of statements
335 when
336 N_Handled_Sequence_Of_Statements =>
337 if Find_SCIL_Node (Statements (P)) then
338 return Found_Node;
339 end if;
341 -- Conditions of while expression or elsif.
343 when N_Iteration_Scheme |
344 N_Elsif_Part
346 if Present (Condition_Actions (P))
347 and then Find_SCIL_Node (Condition_Actions (P))
348 then
349 return Found_Node;
350 end if;
352 -- Statements, declarations, pragmas, representation clauses
354 when
355 -- Statements
357 N_Procedure_Call_Statement |
358 N_Statement_Other_Than_Procedure_Call |
360 -- Pragmas
362 N_Pragma |
364 -- Representation_Clause
366 N_At_Clause |
367 N_Attribute_Definition_Clause |
368 N_Enumeration_Representation_Clause |
369 N_Record_Representation_Clause |
371 -- Declarations
373 N_Abstract_Subprogram_Declaration |
374 N_Entry_Body |
375 N_Exception_Declaration |
376 N_Exception_Renaming_Declaration |
377 N_Formal_Abstract_Subprogram_Declaration |
378 N_Formal_Concrete_Subprogram_Declaration |
379 N_Formal_Object_Declaration |
380 N_Formal_Type_Declaration |
381 N_Full_Type_Declaration |
382 N_Function_Instantiation |
383 N_Generic_Function_Renaming_Declaration |
384 N_Generic_Package_Declaration |
385 N_Generic_Package_Renaming_Declaration |
386 N_Generic_Procedure_Renaming_Declaration |
387 N_Generic_Subprogram_Declaration |
388 N_Implicit_Label_Declaration |
389 N_Incomplete_Type_Declaration |
390 N_Number_Declaration |
391 N_Object_Declaration |
392 N_Object_Renaming_Declaration |
393 N_Package_Body |
394 N_Package_Body_Stub |
395 N_Package_Declaration |
396 N_Package_Instantiation |
397 N_Package_Renaming_Declaration |
398 N_Private_Extension_Declaration |
399 N_Private_Type_Declaration |
400 N_Procedure_Instantiation |
401 N_Protected_Body |
402 N_Protected_Body_Stub |
403 N_Protected_Type_Declaration |
404 N_Single_Task_Declaration |
405 N_Subprogram_Body |
406 N_Subprogram_Body_Stub |
407 N_Subprogram_Declaration |
408 N_Subprogram_Renaming_Declaration |
409 N_Subtype_Declaration |
410 N_Task_Body |
411 N_Task_Body_Stub |
412 N_Task_Type_Declaration |
414 -- Freeze entity behaves like a declaration or statement
416 N_Freeze_Entity
418 -- Do not search here if the item is not a list member
420 if not Is_List_Member (P) then
421 null;
423 -- Do not search if parent of P is an N_Component_Association
424 -- node (i.e. we are in the context of an N_Aggregate or
425 -- N_Extension_Aggregate node). In this case the node should
426 -- have been added before the entire aggregate.
428 elsif Nkind (Parent (P)) = N_Component_Association then
429 null;
431 -- Do not search if the parent of P is either an N_Variant
432 -- node or an N_Record_Definition node. In this case the node
433 -- should have been added before the entire record.
435 elsif Nkind (Parent (P)) = N_Variant
436 or else Nkind (Parent (P)) = N_Record_Definition
437 then
438 null;
440 -- Otherwise search it in the list containing this node
442 elsif Find_SCIL_Node (List_Containing (P)) then
443 return Found_Node;
444 end if;
446 -- A special case, N_Raise_xxx_Error can act either as a statement
447 -- or a subexpression. We diferentiate them by looking at the
448 -- Etype. It is set to Standard_Void_Type in the statement case.
450 when
451 N_Raise_xxx_Error =>
452 if Etype (P) = Standard_Void_Type then
453 if Is_List_Member (P)
454 and then Find_SCIL_Node (List_Containing (P))
455 then
456 return Found_Node;
457 end if;
459 -- In the subexpression case, keep climbing
461 else
462 null;
463 end if;
465 -- If a component association appears within a loop created for
466 -- an array aggregate, check if the SCIL node was added to the
467 -- the list of nodes attached to the association.
469 when
470 N_Component_Association =>
471 if Nkind (Parent (P)) = N_Aggregate
472 and then Present (Loop_Actions (P))
473 and then Find_SCIL_Node (Loop_Actions (P))
474 then
475 return Found_Node;
476 end if;
478 -- Another special case, an attribute denoting a procedure call
480 when
481 N_Attribute_Reference =>
482 if Is_Procedure_Attribute_Name (Attribute_Name (P))
483 and then Find_SCIL_Node (List_Containing (P))
484 then
485 return Found_Node;
487 -- In the subexpression case, keep climbing
489 else
490 null;
491 end if;
493 -- SCIL nodes do not have subtrees and hence they can never be
494 -- found climbing tree
496 when
497 N_SCIL_Dispatch_Table_Object_Init |
498 N_SCIL_Dispatch_Table_Tag_Init |
499 N_SCIL_Dispatching_Call |
500 N_SCIL_Membership_Test |
501 N_SCIL_Tag_Init
503 pragma Assert (False);
504 raise Program_Error;
506 -- For all other node types, keep climbing tree
508 when
509 N_Abortable_Part |
510 N_Accept_Alternative |
511 N_Access_Definition |
512 N_Access_Function_Definition |
513 N_Access_Procedure_Definition |
514 N_Access_To_Object_Definition |
515 N_Aggregate |
516 N_Allocator |
517 N_Case_Statement_Alternative |
518 N_Character_Literal |
519 N_Compilation_Unit |
520 N_Compilation_Unit_Aux |
521 N_Component_Clause |
522 N_Component_Declaration |
523 N_Component_Definition |
524 N_Component_List |
525 N_Constrained_Array_Definition |
526 N_Decimal_Fixed_Point_Definition |
527 N_Defining_Character_Literal |
528 N_Defining_Identifier |
529 N_Defining_Operator_Symbol |
530 N_Defining_Program_Unit_Name |
531 N_Delay_Alternative |
532 N_Delta_Constraint |
533 N_Derived_Type_Definition |
534 N_Designator |
535 N_Digits_Constraint |
536 N_Discriminant_Association |
537 N_Discriminant_Specification |
538 N_Empty |
539 N_Entry_Body_Formal_Part |
540 N_Entry_Call_Alternative |
541 N_Entry_Declaration |
542 N_Entry_Index_Specification |
543 N_Enumeration_Type_Definition |
544 N_Error |
545 N_Exception_Handler |
546 N_Expanded_Name |
547 N_Explicit_Dereference |
548 N_Extension_Aggregate |
549 N_Floating_Point_Definition |
550 N_Formal_Decimal_Fixed_Point_Definition |
551 N_Formal_Derived_Type_Definition |
552 N_Formal_Discrete_Type_Definition |
553 N_Formal_Floating_Point_Definition |
554 N_Formal_Modular_Type_Definition |
555 N_Formal_Ordinary_Fixed_Point_Definition |
556 N_Formal_Package_Declaration |
557 N_Formal_Private_Type_Definition |
558 N_Formal_Signed_Integer_Type_Definition |
559 N_Function_Call |
560 N_Function_Specification |
561 N_Generic_Association |
562 N_Identifier |
563 N_In |
564 N_Index_Or_Discriminant_Constraint |
565 N_Indexed_Component |
566 N_Integer_Literal |
567 N_Itype_Reference |
568 N_Label |
569 N_Loop_Parameter_Specification |
570 N_Mod_Clause |
571 N_Modular_Type_Definition |
572 N_Not_In |
573 N_Null |
574 N_Op_Abs |
575 N_Op_Add |
576 N_Op_And |
577 N_Op_Concat |
578 N_Op_Divide |
579 N_Op_Eq |
580 N_Op_Expon |
581 N_Op_Ge |
582 N_Op_Gt |
583 N_Op_Le |
584 N_Op_Lt |
585 N_Op_Minus |
586 N_Op_Mod |
587 N_Op_Multiply |
588 N_Op_Ne |
589 N_Op_Not |
590 N_Op_Or |
591 N_Op_Plus |
592 N_Op_Rem |
593 N_Op_Rotate_Left |
594 N_Op_Rotate_Right |
595 N_Op_Shift_Left |
596 N_Op_Shift_Right |
597 N_Op_Shift_Right_Arithmetic |
598 N_Op_Subtract |
599 N_Op_Xor |
600 N_Operator_Symbol |
601 N_Ordinary_Fixed_Point_Definition |
602 N_Others_Choice |
603 N_Package_Specification |
604 N_Parameter_Association |
605 N_Parameter_Specification |
606 N_Pop_Constraint_Error_Label |
607 N_Pop_Program_Error_Label |
608 N_Pop_Storage_Error_Label |
609 N_Pragma_Argument_Association |
610 N_Procedure_Specification |
611 N_Protected_Definition |
612 N_Push_Constraint_Error_Label |
613 N_Push_Program_Error_Label |
614 N_Push_Storage_Error_Label |
615 N_Qualified_Expression |
616 N_Range |
617 N_Range_Constraint |
618 N_Real_Literal |
619 N_Real_Range_Specification |
620 N_Record_Definition |
621 N_Reference |
622 N_Selected_Component |
623 N_Signed_Integer_Type_Definition |
624 N_Single_Protected_Declaration |
625 N_Slice |
626 N_String_Literal |
627 N_Subprogram_Info |
628 N_Subtype_Indication |
629 N_Subunit |
630 N_Task_Definition |
631 N_Terminate_Alternative |
632 N_Triggering_Alternative |
633 N_Type_Conversion |
634 N_Unchecked_Expression |
635 N_Unchecked_Type_Conversion |
636 N_Unconstrained_Array_Definition |
637 N_Unused_At_End |
638 N_Unused_At_Start |
639 N_Use_Package_Clause |
640 N_Use_Type_Clause |
641 N_Variant |
642 N_Variant_Part |
643 N_Validate_Unchecked_Conversion |
644 N_With_Clause
646 null;
648 end case;
650 -- If we fall through above tests, keep climbing tree
652 if Nkind (Parent (P)) = N_Subunit then
654 -- This is the proper body corresponding to a stub. Insertion done
655 -- at the point of the stub, which is in the declarative part of
656 -- the parent unit.
658 P := Corresponding_Stub (Parent (P));
660 else
661 P := Parent (P);
662 end if;
663 end loop;
665 -- SCIL node not found
667 return Empty;
668 end Find_SCIL_Node;
670 -------------------------
671 -- First_Non_SCIL_Node --
672 -------------------------
674 function First_Non_SCIL_Node (L : List_Id) return Node_Id is
675 N : Node_Id;
677 begin
678 N := First (L);
679 while Nkind (N) in N_SCIL_Node loop
680 Next (N);
681 end loop;
683 return N;
684 end First_Non_SCIL_Node;
686 ------------------------
687 -- Next_Non_SCIL_Node --
688 ------------------------
690 function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
691 Aux_N : Node_Id;
693 begin
694 Aux_N := Next (N);
695 while Nkind (Aux_N) in N_SCIL_Node loop
696 Next (Aux_N);
697 end loop;
699 return Aux_N;
700 end Next_Non_SCIL_Node;
702 end Sem_SCIL;