1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2009, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Einfo; use Einfo;
27 with Namet; use Namet;
28 with Nlists; use Nlists;
30 with Rtsfind; use Rtsfind;
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
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)
56 Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)
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
68 (Nkind (Original_Node (Old_Node)) = N_Function_Call
69 and then Chars (Name (Original_Node (Old_Node))) =
74 -- Type conversions may involve dispatching calls to functions whose
75 -- associated SCIL dispatching node needs adjustment.
77 elsif Nkind (Old_Node) = N_Type_Conversion then
80 -- Relocated subprogram call
82 elsif Nkind (Old_Node) = Nkind (New_Node)
83 and then Original_Node (Old_Node) = Original_Node (New_Node)
91 -- Search for the SCIL node and update it (if found)
93 SCIL_Node := Find_SCIL_Node (Old_Node);
95 if Present (SCIL_Node) then
96 Set_SCIL_Related_Node (SCIL_Node, New_Node);
100 ---------------------
101 -- Check_SCIL_Node --
102 ---------------------
104 -- Is this a good name for the function, given it only deals with
105 -- N_SCIL_Dispatching_Call case ???
107 function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
109 Ctrl_Typ : Entity_Id;
112 if Nkind (N) = N_SCIL_Dispatching_Call then
113 Ctrl_Tag := SCIL_Controlling_Tag (N);
115 -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
118 if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
119 N_Procedure_Call_Statement)
121 pragma Assert (False);
124 -- In simple cases the controlling tag is the tag of the controlling
125 -- argument (i.e. Obj.Tag).
127 elsif Nkind (Ctrl_Tag) = N_Selected_Component then
128 Ctrl_Typ := Etype (Ctrl_Tag);
130 -- Interface types are unsupported
132 if Is_Interface (Ctrl_Typ)
133 or else (RTE_Available (RE_Interface_Tag)
134 and then Ctrl_Typ = RTE (RE_Interface_Tag))
139 pragma Assert (Ctrl_Typ = RTE (RE_Tag));
143 -- When the controlling tag of a dispatching call is an identifier
144 -- the SCIL_Controlling_Tag attribute references the corresponding
145 -- object or parameter declaration. Interface types are still
148 elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
149 N_Parameter_Specification)
151 Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
153 -- Interface types are unsupported.
155 if Is_Interface (Ctrl_Typ)
156 or else (RTE_Available (RE_Interface_Tag)
157 and then Ctrl_Typ = RTE (RE_Interface_Tag))
158 or else (Is_Access_Type (Ctrl_Typ)
162 (Base_Type (Designated_Type (Ctrl_Typ)))))
168 (Ctrl_Typ = RTE (RE_Tag)
170 (Is_Access_Type (Ctrl_Typ)
171 and then Available_View
172 (Base_Type (Designated_Type (Ctrl_Typ))) =
177 -- Interface types are unsupported
179 elsif Is_Interface (Etype (Ctrl_Tag)) then
183 pragma Assert (False);
189 -- Node is not N_SCIL_Dispatching_Call
200 function Find_SCIL_Node (Node : Node_Id) return Node_Id is
201 Found_Node : Node_Id;
202 -- This variable stores the last node found by the nested subprogram
205 function Find_SCIL_Node (L : List_Id) return Boolean;
206 -- Searches in list L for a SCIL node associated with a dispatching call
207 -- whose SCIL_Related_Node is Node. If found returns true and stores the
208 -- SCIL node in Found_Node; otherwise returns False and sets Found_Node
215 function Find_SCIL_Node (L : List_Id) return Boolean is
220 while Present (N) loop
221 if Nkind (N) in N_SCIL_Node
222 and then SCIL_Related_Node (N) = Node
239 -- Start of processing for Find_SCIL_Node
242 pragma Assert (Generate_SCIL);
244 -- Search for the SCIL node in list associated with a transient scope
246 if Scope_Is_Transient then
248 SE : Scope_Stack_Entry
249 renames Scope_Stack.Table (Scope_Stack.Last);
252 and then Present (SE.Actions_To_Be_Wrapped_Before)
253 and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)
260 -- Otherwise climb up the tree searching for the SCIL node analyzing
261 -- all the lists in which Insert_Actions may have inserted it
264 while Present (P) loop
267 -- Actions associated with AND THEN or OR ELSE
269 when N_Short_Circuit =>
270 if Present (Actions (P))
271 and then Find_SCIL_Node (Actions (P))
276 -- Actions of conditional expressions
278 when N_Conditional_Expression =>
279 if (Present (Then_Actions (P))
280 and then Find_SCIL_Node (Actions (P)))
282 (Present (Else_Actions (P))
283 and then Find_SCIL_Node (Else_Actions (P)))
288 -- Actions in handled sequence of statements
291 N_Handled_Sequence_Of_Statements =>
292 if Find_SCIL_Node (Statements (P)) then
296 -- Conditions of while expression or elsif.
298 when N_Iteration_Scheme |
301 if Present (Condition_Actions (P))
302 and then Find_SCIL_Node (Condition_Actions (P))
307 -- Statements, declarations, pragmas, representation clauses
312 N_Procedure_Call_Statement |
313 N_Statement_Other_Than_Procedure_Call |
319 -- Representation_Clause
322 N_Attribute_Definition_Clause |
323 N_Enumeration_Representation_Clause |
324 N_Record_Representation_Clause |
328 N_Abstract_Subprogram_Declaration |
330 N_Exception_Declaration |
331 N_Exception_Renaming_Declaration |
332 N_Formal_Abstract_Subprogram_Declaration |
333 N_Formal_Concrete_Subprogram_Declaration |
334 N_Formal_Object_Declaration |
335 N_Formal_Type_Declaration |
336 N_Full_Type_Declaration |
337 N_Function_Instantiation |
338 N_Generic_Function_Renaming_Declaration |
339 N_Generic_Package_Declaration |
340 N_Generic_Package_Renaming_Declaration |
341 N_Generic_Procedure_Renaming_Declaration |
342 N_Generic_Subprogram_Declaration |
343 N_Implicit_Label_Declaration |
344 N_Incomplete_Type_Declaration |
345 N_Number_Declaration |
346 N_Object_Declaration |
347 N_Object_Renaming_Declaration |
349 N_Package_Body_Stub |
350 N_Package_Declaration |
351 N_Package_Instantiation |
352 N_Package_Renaming_Declaration |
353 N_Private_Extension_Declaration |
354 N_Private_Type_Declaration |
355 N_Procedure_Instantiation |
357 N_Protected_Body_Stub |
358 N_Protected_Type_Declaration |
359 N_Single_Task_Declaration |
361 N_Subprogram_Body_Stub |
362 N_Subprogram_Declaration |
363 N_Subprogram_Renaming_Declaration |
364 N_Subtype_Declaration |
367 N_Task_Type_Declaration |
369 -- Freeze entity behaves like a declaration or statement
373 -- Do not search here if the item is not a list member
375 if not Is_List_Member (P) then
378 -- Do not search if parent of P is an N_Component_Association
379 -- node (i.e. we are in the context of an N_Aggregate or
380 -- N_Extension_Aggregate node). In this case the node should
381 -- have been added before the entire aggregate.
383 elsif Nkind (Parent (P)) = N_Component_Association then
386 -- Do not search if the parent of P is either an N_Variant
387 -- node or an N_Record_Definition node. In this case the node
388 -- should have been added before the entire record.
390 elsif Nkind (Parent (P)) = N_Variant
391 or else Nkind (Parent (P)) = N_Record_Definition
395 -- Otherwise search it in the list containing this node
397 elsif Find_SCIL_Node (List_Containing (P)) then
401 -- A special case, N_Raise_xxx_Error can act either as a statement
402 -- or a subexpression. We diferentiate them by looking at the
403 -- Etype. It is set to Standard_Void_Type in the statement case.
407 if Etype (P) = Standard_Void_Type then
408 if Is_List_Member (P)
409 and then Find_SCIL_Node (List_Containing (P))
414 -- In the subexpression case, keep climbing
420 -- If a component association appears within a loop created for
421 -- an array aggregate, check if the SCIL node was added to the
422 -- the list of nodes attached to the association.
425 N_Component_Association =>
426 if Nkind (Parent (P)) = N_Aggregate
427 and then Present (Loop_Actions (P))
428 and then Find_SCIL_Node (Loop_Actions (P))
433 -- Another special case, an attribute denoting a procedure call
436 N_Attribute_Reference =>
437 if Is_Procedure_Attribute_Name (Attribute_Name (P))
438 and then Find_SCIL_Node (List_Containing (P))
442 -- In the subexpression case, keep climbing
448 -- SCIL nodes do not have subtrees and hence they can never be
449 -- found climbing tree
452 N_SCIL_Dispatch_Table_Object_Init |
453 N_SCIL_Dispatch_Table_Tag_Init |
454 N_SCIL_Dispatching_Call |
457 pragma Assert (False);
460 -- For all other node types, keep climbing tree
464 N_Accept_Alternative |
465 N_Access_Definition |
466 N_Access_Function_Definition |
467 N_Access_Procedure_Definition |
468 N_Access_To_Object_Definition |
471 N_Case_Statement_Alternative |
472 N_Character_Literal |
474 N_Compilation_Unit_Aux |
476 N_Component_Declaration |
477 N_Component_Definition |
479 N_Constrained_Array_Definition |
480 N_Decimal_Fixed_Point_Definition |
481 N_Defining_Character_Literal |
482 N_Defining_Identifier |
483 N_Defining_Operator_Symbol |
484 N_Defining_Program_Unit_Name |
485 N_Delay_Alternative |
487 N_Derived_Type_Definition |
489 N_Digits_Constraint |
490 N_Discriminant_Association |
491 N_Discriminant_Specification |
493 N_Entry_Body_Formal_Part |
494 N_Entry_Call_Alternative |
495 N_Entry_Declaration |
496 N_Entry_Index_Specification |
497 N_Enumeration_Type_Definition |
499 N_Exception_Handler |
501 N_Explicit_Dereference |
502 N_Extension_Aggregate |
503 N_Floating_Point_Definition |
504 N_Formal_Decimal_Fixed_Point_Definition |
505 N_Formal_Derived_Type_Definition |
506 N_Formal_Discrete_Type_Definition |
507 N_Formal_Floating_Point_Definition |
508 N_Formal_Modular_Type_Definition |
509 N_Formal_Ordinary_Fixed_Point_Definition |
510 N_Formal_Package_Declaration |
511 N_Formal_Private_Type_Definition |
512 N_Formal_Signed_Integer_Type_Definition |
514 N_Function_Specification |
515 N_Generic_Association |
518 N_Index_Or_Discriminant_Constraint |
519 N_Indexed_Component |
523 N_Loop_Parameter_Specification |
525 N_Modular_Type_Definition |
551 N_Op_Shift_Right_Arithmetic |
555 N_Ordinary_Fixed_Point_Definition |
557 N_Package_Specification |
558 N_Parameter_Association |
559 N_Parameter_Specification |
560 N_Pop_Constraint_Error_Label |
561 N_Pop_Program_Error_Label |
562 N_Pop_Storage_Error_Label |
563 N_Pragma_Argument_Association |
564 N_Procedure_Specification |
565 N_Protected_Definition |
566 N_Push_Constraint_Error_Label |
567 N_Push_Program_Error_Label |
568 N_Push_Storage_Error_Label |
569 N_Qualified_Expression |
573 N_Real_Range_Specification |
574 N_Record_Definition |
576 N_Selected_Component |
577 N_Signed_Integer_Type_Definition |
578 N_Single_Protected_Declaration |
582 N_Subtype_Indication |
585 N_Terminate_Alternative |
586 N_Triggering_Alternative |
588 N_Unchecked_Expression |
589 N_Unchecked_Type_Conversion |
590 N_Unconstrained_Array_Definition |
593 N_Use_Package_Clause |
597 N_Validate_Unchecked_Conversion |
604 -- If we fall through above tests, keep climbing tree
606 if Nkind (Parent (P)) = N_Subunit then
608 -- This is the proper body corresponding to a stub. Insertion done
609 -- at the point of the stub, which is in the declarative part of
612 P := Corresponding_Stub (Parent (P));
619 -- SCIL node not found
624 -------------------------
625 -- First_Non_SCIL_Node --
626 -------------------------
628 function First_Non_SCIL_Node (L : List_Id) return Node_Id is
633 while Nkind (N) in N_SCIL_Node loop
638 end First_Non_SCIL_Node;
640 ------------------------
641 -- Next_Non_SCIL_Node --
642 ------------------------
644 function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
649 while Nkind (Aux_N) in N_SCIL_Node loop
654 end Next_Non_SCIL_Node;