[multiple changes]

2017-01-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb (Check_Expression_Against_Static_Predicate):
	If expression is compile-time known and obeys a static predicate
	it must be labelled as static, to prevent spurious warnings and
	run-time errors, e.g. in case statements. This is relevant when
	the expression is the result of constant-folding a type conversion
	whose expression is a variable with a known static value.

2017-01-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb, sem_attr.ads: Minor reformatting.

From-SVN: r244135

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 25f1dfcdbaa4cb4084ff5dd84e579e4ea4a77b87..1dc5958170177d5fb7f4ecb603b27a996de40139 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,16 @@
+2017-01-06  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_eval.adb (Check_Expression_Against_Static_Predicate):
+       If expression is compile-time known and obeys a static predicate
+       it must be labelled as static, to prevent spurious warnings and
+       run-time errors, e.g. in case statements. This is relevant when
+       the expression is the result of constant-folding a type conversion
+       whose expression is a variable with a known static value.
+
+2017-01-06  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_attr.adb, sem_attr.ads: Minor reformatting.
+
 2017-01-06  Justin Squirek  <squirek@adacore.com>
 
        * exp_attr.adb (Expand_N_Attribute_Reference): Add entry for

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index ddc48613e5b3ed8ef5c54eab401bf36cd9c72076..57905df14593fa880a4926429842a3a28945a610 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -3141,11 +3141,10 @@ package body Exp_Attr is
       -----------------------
 
       when Attribute_Finalization_Size => Finalization_Size : declare
-
          function Calculate_Header_Size return Node_Id;
-         --  Generate a runtime call to calculate the size of the hidden
-         --  header along with any added padding which would precede a
-         --  heap-allocated object of the prefix type.
+         --  Generate a runtime call to calculate the size of the hidden header
+         --  along with any added padding which would precede a heap-allocated
+         --  object of the prefix type.
 
          ---------------------------
          -- Calculate_Header_Size --
@@ -3155,46 +3154,47 @@ package body Exp_Attr is
          begin
             --  Generate:
             --    Universal_Integer
-            --      (Header_Size_With_Padding (N'Alignment))
+            --      (Header_Size_With_Padding (Pref'Alignment))
 
             return
               Convert_To (Universal_Integer,
                 Make_Function_Call (Loc,
                   Name                   =>
-                    New_Occurrence_Of
-                      (RTE (RE_Header_Size_With_Padding), Loc),
+                    New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
+
                   Parameter_Associations => New_List (
                     Make_Attribute_Reference (Loc,
-                      Prefix         =>
-                        New_Copy_Tree (Pref),
+                      Prefix         => New_Copy_Tree (Pref),
                       Attribute_Name => Name_Alignment))));
          end Calculate_Header_Size;
 
-      --  Local variables
+         --  Local variables
 
-         Size : constant Entity_Id := Make_Temporary (Loc, 'S');
+         Size : Entity_Id;
 
       --  Start of Finalization_Size
 
       begin
-         --  An object of a class-wide type requires a runtime check to
+         --  An object of a class-wide type first requires a runtime check to
          --  determine whether it is actually controlled or not. Depending on
          --  the outcome of this check, the Finalization_Size of the object
          --  may be zero or some positive value.
          --
-         --  In this scenario, Obj'Finalization_Size is expanded into
+         --  In this scenario, Pref'Finalization_Size is expanded into
          --
-         --   Size : Integer := 0;
+         --    Size : Integer := 0;
          --
-         --   if Needs_Finalization (Pref'Tag) then
-         --      Size :=
-         --        Universal_Integer
-         --          (Header_Size_With_Padding (Pref'Alignment));
-         --  end if;
+         --    if Needs_Finalization (Pref'Tag) then
+         --       Size :=
+         --         Universal_Integer
+         --           (Header_Size_With_Padding (Pref'Alignment));
+         --    end if;
          --
          --  and the attribute reference is replaced with a reference to Size.
 
          if Is_Class_Wide_Type (Ptyp) then
+            Size := Make_Temporary (Loc, 'S');
+
             Insert_Actions (N, New_List (
 
               --  Generate:
@@ -3208,21 +3208,22 @@ package body Exp_Attr is
 
               --  Generate:
               --    if Needs_Finalization (Pref'Tag) then
-              --       Size := Universal_Integer
-              --                 (Header_Size_With_Padding (Pref'Alignment));
+              --       Size :=
+              --         Universal_Integer
+              --           (Header_Size_With_Padding (Pref'Alignment));
               --    end if;
 
               Make_If_Statement (Loc,
                 Condition              =>
                   Make_Function_Call (Loc,
                     Name                   =>
-                      New_Occurrence_Of
-                        (RTE (RE_Needs_Finalization), Loc),
+                      New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
+
                     Parameter_Associations => New_List (
                       Make_Attribute_Reference (Loc,
-                        Attribute_Name => Name_Tag,
-                        Prefix         =>
-                          New_Copy_Tree (Pref)))),
+                        Prefix         => New_Copy_Tree (Pref),
+                        Attribute_Name => Name_Tag))),
+
                 Then_Statements        => New_List (
                    Make_Assignment_Statement (Loc,
                      Name       => New_Occurrence_Of (Size, Loc),
@@ -3230,15 +3231,14 @@ package body Exp_Attr is
 
             Rewrite (N, New_Occurrence_Of (Size, Loc));
 
-         --  The the prefix is known to be controlled at compile time.
-         --  Calculate its Finalization_Size by calling runtime routine
-         --  Header_Size_With_Padding.
+         --  The prefix is known to be controlled at compile time. Calculate
+         --  Finalization_Size by calling function Header_Size_With_Padding.
 
          elsif Needs_Finalization (Ptyp) then
             Rewrite (N, Calculate_Header_Size);
 
-         --  The prefix is not a controlled object, its Finalization_Size
-         --  is zero.
+         --  The prefix is not an object with controlled parts, so its
+         --  Finalization_Size is zero.
 
          else
             Rewrite (N, Make_Integer_Literal (Loc, 0));

diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 2c480f5c9af1996e3224a873d7a54141ec245879..cd11b526e2c6d701b791e97f4cff5a0cfca2b655 100644 (file)
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -247,10 +247,10 @@ package Sem_Attr is
       -----------------------
 
       Attribute_Finalization_Size => True,
-      --  For every object, Finalization_Size will return the size of the
-      --  internal header required for finalization (including padding). If
-      --  the type is not controlled or contains no controlled components
-      --  then the result is always zero.
+      --  For every object, Finalization_Size returns the size of the hidden
+      --  header used for finalization purposes as if the object was allocated
+      --  on the heap. The size of the header does take into account any extra
+      --  padding due to alignment issues.
 
       -----------------
       -- Fixed_Value --

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 314c110fb8d86311343175dc88b8a47f1dbd56a9..fce4643dfbf524d65d4adaf7f56c1a17ebeeb8be 100644 (file)
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -347,7 +347,11 @@ package body Sem_Eval is
 
       --  Here we have a static predicate (note that it could have arisen from
       --  an explicitly specified Dynamic_Predicate whose expression met the
-      --  rules for being predicate-static).
+      --  rules for being predicate-static). If the expression is known at
+      --  compile time and obeys the predicate, then it is static and must be
+      --  labeled as such, which matters e.g. for case statements. The original
+      --  expression may be a type conversion of a variable with a known value,
+      --  which might otherwise not be marked static.
 
       --  Case of real static predicate
 
@@ -356,6 +360,7 @@ package body Sem_Eval is
               (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
                Typ => Typ)
          then
+            Set_Is_Static_Expression (Expr);
             return;
          end if;
 
@@ -365,6 +370,7 @@ package body Sem_Eval is
          if Real_Or_String_Static_Predicate_Matches
               (Val => Expr_Value_S (Expr), Typ => Typ)
          then
+            Set_Is_Static_Expression (Expr);
             return;
          end if;
 
@@ -376,6 +382,7 @@ package body Sem_Eval is
          --  If static predicate matches, nothing to do
 
          if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
+            Set_Is_Static_Expression (Expr);
             return;
          end if;
       end if;