From f915704fd6b530a9712bfe9e8625e0374f2a4e95 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 22 Oct 2010 16:39:44 +0200 Subject: [PATCH] [multiple changes] 2010-10-22 Javier Miranda * sem_aggr.adb (Resolve_Array_Aggregate.Add): If the type of the aggregate has a non standard representation the attributes 'Val and 'Pos expand into function calls and the resulting expression is considered non-safe for reevaluation by the backend. Relocate it into a constant temporary to indicate to the backend that it is side effects free. 2010-10-22 Ed Schonberg * sem_ch3.adb (Build_Concurrent_Derived_Type): Create declaration for derived corresponding record type only when expansion is enabled. From-SVN: r165830 --- gcc/ada/ChangeLog | 14 ++++++++++++ gcc/ada/sem_aggr.adb | 51 +++++++++++++++++++++++++++++++++----------- gcc/ada/sem_ch3.adb | 16 ++++++++------ 3 files changed, 61 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 79b81ca3d2c..4984482bc82 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2010-10-22 Javier Miranda + + * sem_aggr.adb (Resolve_Array_Aggregate.Add): If the type of the + aggregate has a non standard representation the attributes 'Val and + 'Pos expand into function calls and the resulting expression is + considered non-safe for reevaluation by the backend. Relocate it into + a constant temporary to indicate to the backend that it is side + effects free. + +2010-10-22 Ed Schonberg + + * sem_ch3.adb (Build_Concurrent_Derived_Type): Create declaration for + derived corresponding record type only when expansion is enabled. + 2010-10-22 Robert Dewar * sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index b42f1c48302..0a43e858bd6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -891,6 +891,7 @@ package body Sem_Aggr is ----------------------- procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (N); Pkind : constant Node_Kind := Nkind (Parent (N)); Aggr_Subtyp : Entity_Id; @@ -978,8 +979,7 @@ package body Sem_Aggr is Next (Expr); end loop; - Rewrite (N, - Make_String_Literal (Sloc (N), End_String)); + Rewrite (N, Make_String_Literal (Loc, End_String)); Analyze_And_Resolve (N, Typ); return; @@ -999,16 +999,16 @@ package body Sem_Aggr is -- subtype for the final aggregate. begin - -- In the following we determine whether an others choice is + -- In the following we determine whether an OTHERS choice is -- allowed inside the array aggregate. The test checks the context -- in which the array aggregate occurs. If the context does not - -- permit it, or the aggregate type is unconstrained, an others + -- permit it, or the aggregate type is unconstrained, an OTHERS -- choice is not allowed. -- If expansion is disabled (generic context, or semantics-only -- mode) actual subtypes cannot be constructed, and the type of an -- object may be its unconstrained nominal type. However, if the - -- context is an assignment, we assume that "others" is allowed, + -- context is an assignment, we assume that OTHERS is allowed, -- because the target of the assignment will have a constrained -- subtype when fully compiled. @@ -1054,6 +1054,7 @@ package body Sem_Aggr is Index_Constr => First_Index (Typ), Component_Typ => Component_Type (Typ), Others_Allowed => True); + else Aggr_Resolved := Resolve_Array_Aggregate @@ -1092,7 +1093,7 @@ package body Sem_Aggr is if Raises_Constraint_Error (N) then Aggr_Subtyp := Etype (N); Rewrite (N, - Make_Raise_Constraint_Error (Sloc (N), + Make_Raise_Constraint_Error (Loc, Reason => CE_Range_Check_Failed)); Set_Raises_Constraint_Error (N); Set_Etype (N, Aggr_Subtyp); @@ -1133,10 +1134,10 @@ package body Sem_Aggr is -- analyzed expression. procedure Check_Bound (BH : Node_Id; AH : in out Node_Id); - -- Checks that AH (the upper bound of an array aggregate) is <= BH - -- (the upper bound of the index base type). If the check fails a - -- warning is emitted, the Raises_Constraint_Error flag of N is set, - -- and AH is replaced with a duplicate of BH. + -- Checks that AH (the upper bound of an array aggregate) is less than + -- or equal to BH (the upper bound of the index base type). If the check + -- fails, a warning is emitted, the Raises_Constraint_Error flag of N is + -- set, and AH is replaced with a duplicate of BH. procedure Check_Bounds (L, H : Node_Id; AL, AH : Node_Id); -- Checks that range AL .. AH is compatible with range L .. H. Emits a @@ -1160,7 +1161,7 @@ package body Sem_Aggr is -- Resolves aggregate expression Expr. Returns False if resolution -- fails. If Single_Elmt is set to False, the expression Expr may be -- used to initialize several array aggregate elements (this can happen - -- for discrete choices such as "L .. H => Expr" or the others choice). + -- for discrete choices such as "L .. H => Expr" or the OTHERS choice). -- In this event we do not resolve Expr unless expansion is disabled. -- To know why, see the DELAYED COMPONENT RESOLUTION note above. @@ -1211,8 +1212,8 @@ package body Sem_Aggr is if not Is_Enumeration_Type (Index_Base) then Expr := Make_Op_Add (Loc, - Left_Opnd => Duplicate_Subexpr (To), - Right_Opnd => Make_Integer_Literal (Loc, Val)); + Left_Opnd => Duplicate_Subexpr (To), + Right_Opnd => Make_Integer_Literal (Loc, Val)); -- If we are dealing with enumeration return -- Index_Typ'Val (Index_Typ'Pos (To) + Val) @@ -1236,6 +1237,30 @@ package body Sem_Aggr is Prefix => New_Reference_To (Index_Typ, Loc), Attribute_Name => Name_Val, Expressions => New_List (Expr_Pos)); + + -- If the index type has a non standard representation, the + -- attributes 'Val and 'Pos expand into function calls and the + -- resulting expression is considered non-safe for reevaluation + -- by the backend. Relocate it into a constant temporary in order + -- to make it safe for reevaluation. + + if Has_Non_Standard_Rep (Etype (N)) then + declare + Def_Id : Entity_Id; + + begin + Def_Id := Make_Temporary (Loc, 'R', Expr); + Set_Etype (Def_Id, Index_Typ); + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Reference_To (Index_Typ, Loc), + Constant_Present => True, + Expression => Relocate_Node (Expr))); + + Expr := New_Reference_To (Def_Id, Loc); + end; + end if; end if; return Expr; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 68f74b94f01..ab7ce65ac2c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5030,33 +5030,35 @@ package body Sem_Ch3 is end loop; end if; - if Present (Old_Disc) then + if Present (Old_Disc) and then Expander_Active then -- The new type has fewer discriminants, so we need to create a new -- corresponding record, which is derived from the corresponding -- record of the parent, and has a stored constraint that captures -- the values of the discriminant constraints. + -- The corresponding record is needed only if expander is active + -- and code generation is enabled. - -- The type declaration for the derived corresponding record has - -- the same discriminant part and constraints as the current - -- declaration. Copy the unanalyzed tree to build declaration. + -- The type declaration for the derived corresponding record has the + -- same discriminant part and constraints as the current declaration. + -- Copy the unanalyzed tree to build declaration. Corr_Decl_Needed := True; New_N := Copy_Separate_Tree (N); Corr_Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Corr_Record, + Defining_Identifier => Corr_Record, Discriminant_Specifications => Discriminant_Specifications (New_N), - Type_Definition => + Type_Definition => Make_Derived_Type_Definition (Loc, Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Corresponding_Record_Type (Parent_Type), Loc), - Constraint => + Constraint => Constraint (Subtype_Indication (Type_Definition (New_N)))))); end if; -- 2.30.2