diff options
Diffstat (limited to 'gcc/ada/sem_disp.adb')
| -rw-r--r-- | gcc/ada/sem_disp.adb | 105 |
1 files changed, 49 insertions, 56 deletions
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index f64df6f9823..705f428716a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -105,15 +105,13 @@ package body Sem_Disp is begin Formal := First_Formal (Subp); - while Present (Formal) loop Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); if Present (Ctrl_Type) then - -- When the controlling type is concurrent and declared within a - -- generic or inside an instance, use its corresponding record - -- type. + -- When controlling type is concurrent and declared within a + -- generic or inside an instance use corresponding record type. if Is_Concurrent_Type (Ctrl_Type) and then Present (Corresponding_Record_Type (Ctrl_Type)) @@ -124,7 +122,7 @@ package body Sem_Disp is if Ctrl_Type = Typ then Set_Is_Controlling_Formal (Formal); - -- Ada 2005 (AI-231): Anonymous access types used in + -- Ada 2005 (AI-231): Anonymous access types that are used in -- controlling parameters exclude null because it is necessary -- to read the tag to dispatch, and null has no tag. @@ -178,7 +176,10 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - if Present (Etype (Subp)) then + if Ekind (Subp) = E_Function + or else + Ekind (Subp) = E_Generic_Function + then Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); if Present (Ctrl_Type) then @@ -426,14 +427,12 @@ package body Sem_Disp is else Par := Parent (N); - while Present (Par) loop - - if (Nkind (Par) = N_Function_Call or else - Nkind (Par) = N_Procedure_Call_Statement or else - Nkind (Par) = N_Assignment_Statement or else - Nkind (Par) = N_Op_Eq or else - Nkind (Par) = N_Op_Ne) + if Nkind_In (Par, N_Function_Call, + N_Procedure_Call_Statement, + N_Assignment_Statement, + N_Op_Eq, + N_Op_Ne) and then Is_Tagged_Type (Etype (Subp)) then return; @@ -471,11 +470,10 @@ package body Sem_Disp is -- Find a controlling argument, if any if Present (Parameter_Associations (N)) then - Actual := First_Actual (N); - Subp_Entity := Entity (Name (N)); - Formal := First_Formal (Subp_Entity); + Actual := First_Actual (N); + Formal := First_Formal (Subp_Entity); while Present (Actual) loop Control := Find_Controlling_Arg (Actual); exit when Present (Control); @@ -544,7 +542,6 @@ package body Sem_Disp is end if; Actual := First_Actual (N); - while Present (Actual) loop if Actual /= Control then @@ -866,7 +863,7 @@ package body Sem_Disp is -- If the type is already frozen, the overriding is not allowed -- except when Old_Subp is not a dispatching operation (which can -- occur when Old_Subp was inherited by an untagged type). However, - -- a body with no previous spec freezes the type "after" its + -- a body with no previous spec freezes the type *after* its -- declaration, and therefore is a legal overriding (unless the type -- has already been frozen). Only the first such body is legal. @@ -880,7 +877,7 @@ package body Sem_Disp is then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); - Decl_Item : Node_Id := Next (Parent (Tagged_Type)); + Decl_Item : Node_Id; begin -- ??? The checks here for whether the type has been @@ -899,6 +896,7 @@ package body Sem_Disp is -- then the type has been frozen already so the overriding -- primitive is illegal. + Decl_Item := Next (Parent (Tagged_Type)); while Present (Decl_Item) and then (Decl_Item /= Subp_Body) loop @@ -1166,8 +1164,10 @@ package body Sem_Disp is elsif Has_Controlled_Component (Tagged_Type) and then (Chars (Subp) = Name_Initialize - or else Chars (Subp) = Name_Adjust - or else Chars (Subp) = Name_Finalize) + or else + Chars (Subp) = Name_Adjust + or else + Chars (Subp) = Name_Finalize) then declare F_Node : constant Node_Id := Freeze_Node (Tagged_Type); @@ -1187,13 +1187,13 @@ package body Sem_Disp is TSS_Deep_Finalize); begin - -- Remove previous controlled function, which was constructed - -- and analyzed when the type was frozen. This requires - -- removing the body of the redefined primitive, as well as - -- its specification if needed (there is no spec created for - -- Deep_Initialize, see exp_ch3.adb). We must also dismantle - -- the exception information that may have been generated for - -- it when front end zero-cost tables are enabled. + -- Remove previous controlled function which was constructed and + -- analyzed when the type was frozen. This requires removing the + -- body of the redefined primitive, as well as its specification + -- if needed (there is no spec created for Deep_Initialize, see + -- exp_ch3.adb). We must also dismantle the exception information + -- that may have been generated for it when front end zero-cost + -- tables are enabled. for J in D_Names'Range loop Old_P := TSS (Tagged_Type, D_Names (J)); @@ -1217,9 +1217,9 @@ package body Sem_Disp is Build_Late_Proc (Tagged_Type, Chars (Subp)); - -- The new operation is added to the actions of the freeze - -- node for the type, but this node has already been analyzed, - -- so we must retrieve and analyze explicitly the new body. + -- The new operation is added to the actions of the freeze node + -- for the type, but this node has already been analyzed, so we + -- must retrieve and analyze explicitly the new body. if Present (F_Node) and then Present (Actions (F_Node)) @@ -1264,14 +1264,10 @@ package body Sem_Disp is F1 := First_Formal (Proc); F2 := First_Formal (Subp); - while Present (F1) and then Present (F2) loop - if Ekind (Etype (F1)) = E_Anonymous_Access_Type then - if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then return False; - elsif Designated_Type (Etype (F1)) = Parent_Typ and then Designated_Type (Etype (F2)) /= Full then @@ -1304,11 +1300,8 @@ package body Sem_Disp is Op1 := First_Elmt (Old_Prim); Op2 := First_Elmt (New_Prim); - while Present (Op1) and then Present (Op2) loop - if Derives_From (Node (Op1)) then - if No (Prev) then -- Avoid adding it to the list of primitives if already there! @@ -1371,6 +1364,7 @@ package body Sem_Disp is then declare Formal : Entity_Id; + begin Formal := First_Formal (Old_Subp); while Present (Formal) loop @@ -1397,8 +1391,8 @@ package body Sem_Disp is -- Otherwise, update its alias and other attributes. if Present (Alias (Old_Subp)) - and then Nkind (Unit_Declaration_Node (Old_Subp)) - /= N_Subprogram_Renaming_Declaration + and then Nkind (Unit_Declaration_Node (Old_Subp)) /= + N_Subprogram_Renaming_Declaration then Set_Alias (Old_Subp, Alias (Subp)); @@ -1461,24 +1455,22 @@ package body Sem_Disp is Typ := Etype (N); if Is_Access_Type (Typ) then - -- In the case of an Access attribute, use the type of - -- the prefix, since in the case of an actual for an - -- access parameter, the attribute's type may be of a - -- specific designated type, even though the prefix - -- type is class-wide. + + -- In the case of an Access attribute, use the type of the prefix, + -- since in the case of an actual for an access parameter, the + -- attribute's type may be of a specific designated type, even + -- though the prefix type is class-wide. if Nkind (N) = N_Attribute_Reference then Typ := Etype (Prefix (N)); - -- An allocator is dispatching if the type of qualified - -- expression is class_wide, in which case this is the - -- controlling type. + -- An allocator is dispatching if the type of qualified expression + -- is class_wide, in which case this is the controlling type. elsif Nkind (Orig_Node) = N_Allocator and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression then Typ := Etype (Expression (Orig_Node)); - else Typ := Designated_Type (Typ); end if; @@ -1560,6 +1552,7 @@ package body Sem_Disp is end if; end if; + pragma Assert (not Is_Dispatching_Operation (Subp)); return Empty; end Find_Dispatching_Type; @@ -1800,9 +1793,9 @@ package body Sem_Disp is elsif Nkind (Actual) = N_Identifier and then Nkind (Original_Node (Actual)) = N_Function_Call then - -- Call rewritten as object declaration when stack-checking - -- is enabled. Propagate tag to expression in declaration, which - -- is original call. + -- Call rewritten as object declaration when stack-checking is + -- enabled. Propagate tag to expression in declaration, which is + -- original call. Call_Node := Expression (Parent (Entity (Actual))); @@ -1823,8 +1816,8 @@ package body Sem_Disp is Call_Node := Expression (Actual); end if; - -- Do not set the Controlling_Argument if already set. This happens - -- in the special case of _Input (see Exp_Attr, case Input). + -- Do not set the Controlling_Argument if already set. This happens in + -- the special case of _Input (see Exp_Attr, case Input). if No (Controlling_Argument (Call_Node)) then Set_Controlling_Argument (Call_Node, Control); @@ -1841,8 +1834,8 @@ package body Sem_Disp is end loop; -- Expansion of dispatching calls is suppressed when VM_Target, because - -- the VM back-ends directly handle the generation of dispatching - -- calls and would have to undo any expansion to an indirect call. + -- the VM back-ends directly handle the generation of dispatching calls + -- and would have to undo any expansion to an indirect call. if Tagged_Type_Expansion then Expand_Dispatching_Call (Call_Node); |