diff options
-rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
-rw-r--r-- | gcc/ada/exp_alfa.adb | 16 | ||||
-rw-r--r-- | gcc/ada/exp_ch8.adb | 94 | ||||
-rw-r--r-- | gcc/ada/exp_ch8.ads | 4 | ||||
-rw-r--r-- | gcc/ada/exp_util.adb | 174 | ||||
-rw-r--r-- | gcc/ada/exp_util.ads | 4 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 10 |
7 files changed, 193 insertions, 133 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a6f30bf..dce0797 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2011-11-07 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_alfa.adb: Remove with and use clause for + Exp_Ch8. Add with and use clause for Exp_Util. + Remove local constant Disable_Processing_Of_Renamings. + (Expand_Alfa_N_Object_Renaming_Declaration): The expansion of + object renamings has been reenabled. + (Expand_Possible_Renaming): + The expansion of identifier and expanded names has been + reenabled. Perform the substitutions only for entities that + denote an object. + * exp_ch8.ads, exp_ch8.adb (Evaluate_Name): Moved to Exp_Util. + * exp_util.adb (Evaluate_Name): Moved from Exp_Ch8. + (Remove_Side_Effects): Alphabetize local variables. Add a guard + to avoid the infinite expansion of an expression in Alfa mode. Add + processing for function calls in Alfa mode. + * exp_util.ads (Evaliate_Name): Moved from Exp_Ch8. + +2011-11-07 Ed Schonberg <schonberg@adacore.com> + + * freeze.adb (Freeze_Entity): If the entity is an access to + subprogram whose designated type is itself a subprogram type, + its own return type must be decorated with size information. + 2011-11-04 Arnaud Charlet <charlet@adacore.com> * gcc-interface/Make-lang.in: Update dependencies. diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb index 844fe89..e2424da 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_alfa.adb @@ -28,8 +28,8 @@ with Einfo; use Einfo; with Exp_Attr; use Exp_Attr; with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; -with Exp_Ch8; use Exp_Ch8; with Exp_Dbug; use Exp_Dbug; +with Exp_Util; use Exp_Util; with Nlists; use Nlists; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; @@ -42,8 +42,6 @@ with Tbuild; use Tbuild; package body Exp_Alfa is - Disable_Processing_Of_Renamings : constant Boolean := True; - ----------------------- -- Local Subprograms -- ----------------------- @@ -211,10 +209,6 @@ package body Exp_Alfa is procedure Expand_Alfa_N_Object_Renaming_Declaration (N : Node_Id) is begin - if Disable_Processing_Of_Renamings then - return; - end if; - -- Unconditionally remove all side effects from the name Evaluate_Name (Name (N)); @@ -303,13 +297,11 @@ package body Exp_Alfa is T : constant Entity_Id := Etype (N); begin - if Disable_Processing_Of_Renamings then - return; - end if; - -- Substitute a reference to a renaming with the actual renamed object - if Present (Renamed_Object (E)) then + if Ekind (E) in Object_Kind + and then Present (Renamed_Object (E)) + then Rewrite (N, New_Copy_Tree (Renamed_Object (E))); Reset_Analyzed_Flags (N); diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index c1fc7e8..f6f62d7 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -44,100 +44,6 @@ with Tbuild; use Tbuild; package body Exp_Ch8 is - ------------------- - -- Evaluate_Name -- - ------------------- - - procedure Evaluate_Name (Nam : Node_Id) is - K : constant Node_Kind := Nkind (Nam); - - begin - -- For an explicit dereference, we simply force the evaluation of the - -- name expression. The dereference provides a value that is the address - -- for the renamed object, and it is precisely this value that we want - -- to preserve. - - if K = N_Explicit_Dereference then - Force_Evaluation (Prefix (Nam)); - - -- For a selected component, we simply evaluate the prefix - - elsif K = N_Selected_Component then - Evaluate_Name (Prefix (Nam)); - - -- For an indexed component, or an attribute reference, we evaluate the - -- prefix, which is itself a name, recursively, and then force the - -- evaluation of all the subscripts (or attribute expressions). - - elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then - Evaluate_Name (Prefix (Nam)); - - declare - E : Node_Id; - - begin - E := First (Expressions (Nam)); - while Present (E) loop - Force_Evaluation (E); - - if Original_Node (E) /= E then - Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); - end if; - - Next (E); - end loop; - end; - - -- For a slice, we evaluate the prefix, as for the indexed component - -- case and then, if there is a range present, either directly or as the - -- constraint of a discrete subtype indication, we evaluate the two - -- bounds of this range. - - elsif K = N_Slice then - Evaluate_Name (Prefix (Nam)); - - declare - DR : constant Node_Id := Discrete_Range (Nam); - Constr : Node_Id; - Rexpr : Node_Id; - - begin - if Nkind (DR) = N_Range then - Force_Evaluation (Low_Bound (DR)); - Force_Evaluation (High_Bound (DR)); - - elsif Nkind (DR) = N_Subtype_Indication then - Constr := Constraint (DR); - - if Nkind (Constr) = N_Range_Constraint then - Rexpr := Range_Expression (Constr); - - Force_Evaluation (Low_Bound (Rexpr)); - Force_Evaluation (High_Bound (Rexpr)); - end if; - end if; - end; - - -- For a type conversion, the expression of the conversion must be the - -- name of an object, and we simply need to evaluate this name. - - elsif K = N_Type_Conversion then - Evaluate_Name (Expression (Nam)); - - -- For a function call, we evaluate the call - - elsif K = N_Function_Call then - Force_Evaluation (Nam); - - -- The remaining cases are direct name, operator symbol and character - -- literal. In all these cases, we do nothing, since we want to - -- reevaluate each time the renamed object is used. - - else - return; - end if; - end Evaluate_Name; - --------------------------------------------- -- Expand_N_Exception_Renaming_Declaration -- --------------------------------------------- diff --git a/gcc/ada/exp_ch8.ads b/gcc/ada/exp_ch8.ads index b5056ab..d5dd37c 100644 --- a/gcc/ada/exp_ch8.ads +++ b/gcc/ada/exp_ch8.ads @@ -33,8 +33,4 @@ package Exp_Ch8 is procedure Expand_N_Package_Renaming_Declaration (N : Node_Id); procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id); - procedure Evaluate_Name (Nam : Node_Id); - -- Remove the all side effects from a name except for the outermost - -- construct. - end Exp_Ch8; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 2045201..e675da8 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1759,6 +1759,100 @@ package body Exp_Util is and then not Restriction_Active (No_Local_Allocators); end Entry_Names_OK; + ------------------- + -- Evaluate_Name -- + ------------------- + + procedure Evaluate_Name (Nam : Node_Id) is + K : constant Node_Kind := Nkind (Nam); + + begin + -- For an explicit dereference, we simply force the evaluation of the + -- name expression. The dereference provides a value that is the address + -- for the renamed object, and it is precisely this value that we want + -- to preserve. + + if K = N_Explicit_Dereference then + Force_Evaluation (Prefix (Nam)); + + -- For a selected component, we simply evaluate the prefix + + elsif K = N_Selected_Component then + Evaluate_Name (Prefix (Nam)); + + -- For an indexed component, or an attribute reference, we evaluate the + -- prefix, which is itself a name, recursively, and then force the + -- evaluation of all the subscripts (or attribute expressions). + + elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then + Evaluate_Name (Prefix (Nam)); + + declare + E : Node_Id; + + begin + E := First (Expressions (Nam)); + while Present (E) loop + Force_Evaluation (E); + + if Original_Node (E) /= E then + Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E))); + end if; + + Next (E); + end loop; + end; + + -- For a slice, we evaluate the prefix, as for the indexed component + -- case and then, if there is a range present, either directly or as the + -- constraint of a discrete subtype indication, we evaluate the two + -- bounds of this range. + + elsif K = N_Slice then + Evaluate_Name (Prefix (Nam)); + + declare + DR : constant Node_Id := Discrete_Range (Nam); + Constr : Node_Id; + Rexpr : Node_Id; + + begin + if Nkind (DR) = N_Range then + Force_Evaluation (Low_Bound (DR)); + Force_Evaluation (High_Bound (DR)); + + elsif Nkind (DR) = N_Subtype_Indication then + Constr := Constraint (DR); + + if Nkind (Constr) = N_Range_Constraint then + Rexpr := Range_Expression (Constr); + + Force_Evaluation (Low_Bound (Rexpr)); + Force_Evaluation (High_Bound (Rexpr)); + end if; + end if; + end; + + -- For a type conversion, the expression of the conversion must be the + -- name of an object, and we simply need to evaluate this name. + + elsif K = N_Type_Conversion then + Evaluate_Name (Expression (Nam)); + + -- For a function call, we evaluate the call + + elsif K = N_Function_Call then + Force_Evaluation (Nam); + + -- The remaining cases are direct name, operator symbol and character + -- literal. In all these cases, we do nothing, since we want to + -- reevaluate each time the renamed object is used. + + else + return; + end if; + end Evaluate_Name; + --------------------- -- Evolve_And_Then -- --------------------- @@ -5921,11 +6015,11 @@ package body Exp_Util is Exp_Type : constant Entity_Id := Etype (Exp); Svg_Suppress : constant Suppress_Array := Scope_Suppress; Def_Id : Entity_Id; + E : Node_Id; + New_Exp : Node_Id; + Ptr_Typ_Decl : Node_Id; Ref_Type : Entity_Id; Res : Node_Id; - Ptr_Typ_Decl : Node_Id; - New_Exp : Node_Id; - E : Node_Id; function Side_Effect_Free (N : Node_Id) return Boolean; -- Determines if the tree N represents an expression that is known not @@ -6160,7 +6254,7 @@ package body Exp_Util is -- A binary operator is side effect free if and both operands are -- side effect free. For this purpose binary operators include - -- membership tests and short circuit forms + -- membership tests and short circuit forms. when N_Binary_Op | N_Membership_Test | N_Short_Circuit => return Side_Effect_Free (Left_Opnd (N)) @@ -6528,6 +6622,15 @@ package body Exp_Util is -- Otherwise we generate a reference to the value else + -- An expression which is in Alfa mode is considered side effect free + -- if the resulting value is captured by a variable or a constant. + + if Alfa_Mode + and then Nkind (Parent (Exp)) = N_Object_Declaration + then + return; + end if; + -- Special processing for function calls that return a limited type. -- We need to build a declaration that will enable build-in-place -- expansion of the call. This is not done if the context is already @@ -6536,10 +6639,10 @@ package body Exp_Util is -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have -- to accommodate functions returning limited objects by reference. - if Nkind (Exp) = N_Function_Call + if Ada_Version >= Ada_2005 + and then Nkind (Exp) = N_Function_Call and then Is_Immutably_Limited_Type (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration - and then Ada_Version >= Ada_2005 then declare Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp); @@ -6559,32 +6662,57 @@ package body Exp_Util is end; end if; - Ref_Type := Make_Temporary (Loc, 'A'); + Def_Id := Make_Temporary (Loc, 'R', Exp); + Set_Etype (Def_Id, Exp_Type); + + -- The regular expansion of functions with side effects involves the + -- generation of an access type to capture the return value found on + -- the secondary stack. Since Alfa (and why) cannot process access + -- types, use a different approach which ignores the secondary stack + -- and "copies" the returned object. - Ptr_Typ_Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Ref_Type, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => - New_Reference_To (Exp_Type, Loc))); + if Alfa_Mode then + Res := New_Reference_To (Def_Id, Loc); + Ref_Type := Exp_Type; - E := Exp; - Insert_Action (Exp, Ptr_Typ_Decl); + -- Regular expansion utilizing an access type and 'reference - Def_Id := Make_Temporary (Loc, 'R', Exp); - Set_Etype (Def_Id, Exp_Type); + else + Res := + Make_Explicit_Dereference (Loc, + Prefix => New_Reference_To (Def_Id, Loc)); - Res := - Make_Explicit_Dereference (Loc, - Prefix => New_Reference_To (Def_Id, Loc)); + -- Generate: + -- type Ann is access all <Exp_Type>; + Ref_Type := Make_Temporary (Loc, 'A'); + + Ptr_Typ_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Ref_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + New_Reference_To (Exp_Type, Loc))); + + Insert_Action (Exp, Ptr_Typ_Decl); + end if; + + E := Exp; if Nkind (E) = N_Explicit_Dereference then New_Exp := Relocate_Node (Prefix (E)); else E := Relocate_Node (E); - New_Exp := Make_Reference (Loc, E); + + -- Do not generate a 'reference in Alfa mode since the access type + -- is not created in the first place. + + if Alfa_Mode then + New_Exp := E; + else + New_Exp := Make_Reference (Loc, E); + end if; end if; if Is_Delayed_Aggregate (E) then diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 94512b6..f293b8f 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -351,6 +351,10 @@ package Exp_Util is -- which represent entry [family member] names. These strings are created -- by the compiler and used by GDB. + procedure Evaluate_Name (Nam : Node_Id); + -- Remove the all side effects from a name which appears as part of an + -- object renaming declaration. + procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id); -- Rewrites Cond with the expression: Cond and then Cond1. If Cond is -- Empty, then simply returns Cond1 (this allows the use of Empty to diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8c42fed..b1a33d5 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4063,6 +4063,16 @@ package body Freeze is Layout_Type (E); end if; + -- If this is an access to subprogram whose designated type is itself + -- a subprogram type, the return type of this anonymous subprogram + -- type must be decorated as well. + + if Ekind (E) = E_Anonymous_Access_Subprogram_Type + and then Ekind (Designated_Type (E)) = E_Subprogram_Type + then + Layout_Type (Etype (Designated_Type (E))); + end if; + -- If the type has a Defaut_Value/Default_Component_Value aspect, -- this is where we analye the expression (after the type is frozen, -- since in the case of Default_Value, we are analyzing with the |