diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2010-10-22 16:39:44 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2010-10-22 16:39:44 +0200 |
commit | f915704fd6b530a9712bfe9e8625e0374f2a4e95 (patch) | |
tree | ea196a7c44083941b3599a1fe990b421f7e8edc8 /gcc/ada | |
parent | ed00f4727ba26dd7b6cb3900162729d26de9ecdb (diff) | |
download | gcc-f915704fd6b530a9712bfe9e8625e0374f2a4e95.zip gcc-f915704fd6b530a9712bfe9e8625e0374f2a4e95.tar.gz gcc-f915704fd6b530a9712bfe9e8625e0374f2a4e95.tar.bz2 |
[multiple changes]
2010-10-22 Javier Miranda <miranda@adacore.com>
* 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 <schonberg@adacore.com>
* sem_ch3.adb (Build_Concurrent_Derived_Type): Create declaration for
derived corresponding record type only when expansion is enabled.
From-SVN: r165830
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 14 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 51 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 16 |
3 files changed, 61 insertions, 20 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 79b81ca..4984482 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2010-10-22 Javier Miranda <miranda@adacore.com> + + * 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 <schonberg@adacore.com> + + * sem_ch3.adb (Build_Concurrent_Derived_Type): Create declaration for + derived corresponding record type only when expansion is enabled. + 2010-10-22 Robert Dewar <dewar@adacore.com> * 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 b42f1c4..0a43e85 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 68f74b9..ab7ce65 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; |