diff options
Diffstat (limited to 'gcc/ada/exp_util.adb')
| -rw-r--r-- | gcc/ada/exp_util.adb | 258 |
1 files changed, 149 insertions, 109 deletions
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c450b677faf..b9e5d389fce 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, 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- -- @@ -43,7 +43,6 @@ with Rident; use Rident; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; -with Sem_SCIL; use Sem_SCIL; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -306,11 +305,9 @@ package body Exp_Util is else if No (Actions (Fnode)) then Set_Actions (Fnode, L); - else Append_List (L, Actions (Fnode)); end if; - end if; end Append_Freeze_Actions; @@ -398,7 +395,7 @@ package body Exp_Util is Pos : Entity_Id; -- Running index for substring assignments - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Res : Entity_Id; @@ -417,8 +414,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -444,7 +439,7 @@ package body Exp_Util is Val := First (Expressions (Id_Ref)); for J in 1 .. Dims loop - T := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Temps (J) := T; Append_To (Decls, @@ -454,10 +449,8 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Image, - Prefix => - New_Occurrence_Of (Etype (Indx), Loc), - Expressions => New_List ( - New_Copy_Tree (Val))))); + Prefix => New_Occurrence_Of (Etype (Indx), Loc), + Expressions => New_List (New_Copy_Tree (Val))))); Next_Index (Indx); Next (Val); @@ -613,7 +606,7 @@ package body Exp_Util is if Restriction_Active (No_Implicit_Heap_Allocations) or else Global_Discard_Names then - T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); + T_Id := Make_Temporary (Loc, 'J'); Name_Len := 0; return @@ -697,9 +690,8 @@ package body Exp_Util is Expression => New_Occurrence_Of (Res, Loc))); Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Result_Definition => New_Occurrence_Of (Standard_String, Loc)); + Defining_Unit_Name => Make_Temporary (Loc, 'F'), + Result_Definition => New_Occurrence_Of (Standard_String, Loc)); -- Calls to 'Image use the secondary stack, which must be cleaned -- up after the task name is built. @@ -726,15 +718,15 @@ package body Exp_Util is Stats : List_Id) is begin - Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Len := Make_Temporary (Loc, 'L', Sum); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Len, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), - Expression => Sum)); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc), + Expression => Sum)); - Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Res := Make_Temporary (Loc, 'R'); Append_To (Decls, Make_Object_Declaration (Loc, @@ -750,12 +742,12 @@ package body Exp_Util is Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Len, Loc))))))); - Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Pos := Make_Temporary (Loc, 'P'); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Pos, - Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); + Object_Definition => New_Occurrence_Of (Standard_Integer, Loc))); -- Pos := Prefix'Length; @@ -765,29 +757,29 @@ package body Exp_Util is Expression => Make_Attribute_Reference (Loc, Attribute_Name => Name_Length, - Prefix => New_Occurrence_Of (Prefix, Loc), - Expressions => - New_List (Make_Integer_Literal (Loc, 1))))); + Prefix => New_Occurrence_Of (Prefix, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, 1))))); -- Res (1 .. Pos) := Prefix; Append_To (Stats, - Make_Assignment_Statement (Loc, - Name => Make_Slice (Loc, - Prefix => New_Occurrence_Of (Res, Loc), + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Res, Loc), Discrete_Range => Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), + Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => New_Occurrence_Of (Pos, Loc))), - Expression => New_Occurrence_Of (Prefix, Loc))); + Expression => New_Occurrence_Of (Prefix, Loc))); Append_To (Stats, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Pos, Loc), + Name => New_Occurrence_Of (Pos, Loc), Expression => Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Pos, Loc), + Left_Opnd => New_Occurrence_Of (Pos, Loc), Right_Opnd => Make_Integer_Literal (Loc, 1)))); end Build_Task_Image_Prefix; @@ -809,7 +801,7 @@ package body Exp_Util is Res : Entity_Id; -- String to hold result - Pref : Entity_Id; + Pref : constant Entity_Id := Make_Temporary (Loc, 'P'); -- Name of enclosing variable, prefix of resulting name Sum : Node_Id; @@ -822,8 +814,6 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - -- For a dynamic task, the name comes from the target variable. -- For a static one it is a formal of the enclosing init proc. @@ -845,15 +835,15 @@ package body Exp_Util is Name => Make_Identifier (Loc, Name_uTask_Name))); end if; - Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Sel := Make_Temporary (Loc, 'S'); Get_Name_String (Chars (Selector_Name (Id_Ref))); Append_To (Decls, Make_Object_Declaration (Loc, Defining_Identifier => Sel, - Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => + Object_Definition => New_Occurrence_Of (Standard_String, Loc), + Expression => Make_String_Literal (Loc, Strval => String_From_Name_Buffer))); @@ -1300,9 +1290,7 @@ package body Exp_Util is end if; else - T := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('T')); + T := Make_Temporary (Loc, 'T'); Insert_Action (N, Make_Subtype_Declaration (Loc, @@ -1496,7 +1484,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle task and protected types implementing interfaces @@ -1603,7 +1591,7 @@ package body Exp_Util is -- Handle access types if Is_Access_Type (Typ) then - Typ := Directly_Designated_Type (Typ); + Typ := Designated_Type (Typ); end if; -- Handle class-wide types @@ -1679,7 +1667,7 @@ package body Exp_Util is exit when Chars (Op) = Name and then (Name /= Name_Op_Eq - or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op))); + or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op))); Next_Elmt (Prim); @@ -2016,6 +2004,17 @@ package body Exp_Util is -- unknown before the ELSE part or after the IF statement. elsif Nkind (CV) = N_Elsif_Part then + + -- if the Elsif_Part had condition_actions, the elsif has been + -- rewritten as a nested if, and the original elsif_part is + -- detached from the tree, so there is no way to obtain useful + -- information on the current value of the variable. + -- Can this be improved ??? + + if No (Parent (CV)) then + return; + end if; + Stm := Parent (CV); -- Before start of ELSIF part @@ -2116,9 +2115,7 @@ package body Exp_Util is begin -- Only consider record types - if Ekind (Typ) /= E_Record_Type - and then Ekind (Typ) /= E_Record_Subtype - then + if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then return False; end if; @@ -2129,9 +2126,9 @@ package body Exp_Util is if Ekind (D_Typ) = E_Anonymous_Access_Type and then - (Is_Controlled (Directly_Designated_Type (D_Typ)) + (Is_Controlled (Designated_Type (D_Typ)) or else - Is_Concurrent_Type (Directly_Designated_Type (D_Typ))) + Is_Concurrent_Type (Designated_Type (D_Typ))) then return True; end if; @@ -2143,6 +2140,37 @@ package body Exp_Util is return False; end Has_Controlled_Coextensions; + ------------------------ + -- Has_Address_Clause -- + ------------------------ + + -- Should this function check the private part in a package ??? + + function Has_Following_Address_Clause (D : Node_Id) return Boolean is + Id : constant Entity_Id := Defining_Identifier (D); + Decl : Node_Id; + + begin + Decl := Next (D); + while Present (Decl) loop + if Nkind (Decl) = N_At_Clause + and then Chars (Identifier (Decl)) = Chars (Id) + then + return True; + + elsif Nkind (Decl) = N_Attribute_Definition_Clause + and then Chars (Decl) = Name_Address + and then Chars (Name (Decl)) = Chars (Id) + then + return True; + end if; + + Next (Decl); + end loop; + + return False; + end Has_Following_Address_Clause; + -------------------- -- Homonym_Number -- -------------------- @@ -2397,6 +2425,28 @@ package body Exp_Util is end if; end; + -- Alternative of case expression, we place the action in + -- the Actions field of the case expression alternative, this + -- will be handled when the case expression is expanded. + + when N_Case_Expression_Alternative => + if Present (Actions (P)) then + Insert_List_After_And_Analyze + (Last (Actions (P)), Ins_Actions); + else + Set_Actions (P, Ins_Actions); + Analyze_List (Then_Actions (P)); + end if; + + return; + + -- Case of appearing within an Expressions_With_Actions node. We + -- prepend the actions to the list of actions already there. + + when N_Expression_With_Actions => + Prepend_List (Ins_Actions, Actions (P)); + return; + -- Case of appearing in the condition of a while expression or -- elsif. We insert the actions into the Condition_Actions field. -- They will be moved further out when the while loop or elsif @@ -2652,6 +2702,7 @@ package body Exp_Util is N_Access_To_Object_Definition | N_Aggregate | N_Allocator | + N_Case_Expression | N_Case_Statement_Alternative | N_Character_Literal | N_Compilation_Unit | @@ -2758,11 +2809,9 @@ package body Exp_Util is N_Real_Range_Specification | N_Record_Definition | N_Reference | - N_SCIL_Dispatch_Table_Object_Init | N_SCIL_Dispatch_Table_Tag_Init | N_SCIL_Dispatching_Call | N_SCIL_Membership_Test | - N_SCIL_Tag_Init | N_Selected_Component | N_Signed_Integer_Type_Definition | N_Single_Protected_Declaration | @@ -3093,16 +3142,23 @@ package body Exp_Util is end if; end if; + -- The following code is historical, it used to be present but it + -- is too cautious, because the front-end does not know the proper + -- default alignments for the target. Also, if the alignment is + -- not known, the front end can't know in any case! If a copy is + -- needed, the back-end will take care of it. This whole section + -- including this comment can be removed later ??? + -- If the component reference is for a record that has a specified -- alignment, and we either know it is too small, or cannot tell, - -- then the component may be unaligned + -- then the component may be unaligned. - if Known_Alignment (Etype (P)) - and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment - and then M > Alignment (Etype (P)) - then - return True; - end if; + -- if Known_Alignment (Etype (P)) + -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment + -- and then M > Alignment (Etype (P)) + -- then + -- return True; + -- end if; -- Case of component clause present which may specify an -- unaligned position. @@ -3724,24 +3780,27 @@ package body Exp_Util is Sizexpr : Node_Id; begin - if not Has_Discriminants (Root_Typ) then + -- If the root type is already constrained, there are no discriminants + -- in the expression. + + if not Has_Discriminants (Root_Typ) + or else Is_Constrained (Root_Typ) + then Constr_Root := Root_Typ; else - Constr_Root := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Constr_Root := Make_Temporary (Loc, 'R'); -- subtype cstr__n is T (List of discr constraints taken from Exp) Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Constr_Root, - Subtype_Indication => - Make_Subtype_From_Expr (E, Root_Typ))); + Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ))); end if; -- Generate the range subtype declaration - Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G')); + Range_Type := Make_Temporary (Loc, 'G'); if not Is_Interface (Root_Typ) then @@ -3790,7 +3849,7 @@ package body Exp_Util is -- subtype str__nn is Storage_Array (rg__x); - Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Str_Type := Make_Temporary (Loc, 'S'); Append_To (List_Def, Make_Subtype_Declaration (Loc, Defining_Identifier => Str_Type, @@ -3807,7 +3866,7 @@ package body Exp_Util is -- E : Str_Type; -- end Equiv_T; - Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Equiv_Type := Make_Temporary (Loc, 'T'); Set_Ekind (Equiv_Type, E_Record_Type); Set_Parent_Subtype (Equiv_Type, Constr_Root); @@ -3832,9 +3891,7 @@ package body Exp_Util is Append_To (Comp_List, Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('C')), + Defining_Identifier => Make_Temporary (Loc, 'C'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -3960,15 +4017,12 @@ package body Exp_Util is -- actual or an explicit subtype. Utyp := Underlying_Type (Base_Type (Unc_Typ)); - Full_Subtyp := Make_Defining_Identifier (Loc, - New_Internal_Name ('C')); + Full_Subtyp := Make_Temporary (Loc, 'C'); Full_Exp := - Unchecked_Convert_To - (Utyp, Duplicate_Subexpr_No_Checks (E)); + Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E)); Set_Parent (Full_Exp, Parent (E)); - Priv_Subtyp := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Priv_Subtyp := Make_Temporary (Loc, 'P'); Insert_Action (E, Make_Subtype_Declaration (Loc, @@ -4027,6 +4081,20 @@ package body Exp_Util is -- additional intermediate type to handle the assignment). if Expander_Active and then Tagged_Type_Expansion then + + -- If this is the class_wide type of a completion that is + -- a record subtype, set the type of the class_wide type + -- to be the full base type, for use in the expanded code + -- for the equivalent type. Should this be done earlier when + -- the completion is analyzed ??? + + if Is_Private_Type (Etype (Unc_Typ)) + and then + Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype + then + Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ)))); + end if; + EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E); end if; @@ -4391,9 +4459,7 @@ package body Exp_Util is -- already rewritten a variable node with a constant as -- a result of an earlier Force_Evaluation call. - if Ekind (Entity (N)) = E_Constant - or else Ekind (Entity (N)) = E_In_Parameter - then + if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then return True; -- Functions are not side effect free @@ -4631,14 +4697,15 @@ package body Exp_Util is Scope_Suppress := (others => True); -- If it is a scalar type and we need to capture the value, just make - -- a copy. Likewise for a function call, an attribute reference or an - -- operator. And if we have a volatile reference and Name_Req is not - -- set (see comments above for Side_Effect_Free). + -- a copy. Likewise for a function call, an attribute reference, an + -- allocator, or an operator. And if we have a volatile reference and + -- Name_Req is not set (see comments above for Side_Effect_Free). if Is_Elementary_Type (Exp_Type) and then (Variable_Ref or else Nkind (Exp) = N_Function_Call or else Nkind (Exp) = N_Attribute_Reference + or else Nkind (Exp) = N_Allocator or else Nkind (Exp) in N_Op or else (not Name_Req and then Is_Volatile_Reference (Exp))) then @@ -4653,15 +4720,6 @@ package body Exp_Util is Constant_Present => True, Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment of - -- some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (E)); - end if; - Set_Assignment_OK (E); Insert_Action (Exp, E); @@ -4823,15 +4881,6 @@ package body Exp_Util is Object_Definition => New_Occurrence_Of (Exp_Type, Loc), Expression => Relocate_Node (Exp)); - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Expression (Decl)); - end if; - Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); @@ -4839,7 +4888,7 @@ package body Exp_Util is end; end if; - Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Ref_Type := Make_Temporary (Loc, 'A'); Ptr_Typ_Decl := Make_Full_Type_Declaration (Loc, @@ -4891,15 +4940,6 @@ package body Exp_Util is Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Exp)); - - -- Check if the previous node relocation requires readjustment - -- of some SCIL Dispatching node. - - if Generate_SCIL - and then Nkind (Exp) = N_Function_Call - then - Adjust_SCIL_Node (Exp, Prefix (New_Exp)); - end if; end if; -- Preserve the Assignment_OK flag in all copies, since at least |