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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165830 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 79b81ca..4984482 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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;