2011-11-21 Robert Dewar <dewar@adacore.com>

	* exp_imgv.adb (Expand_Width_Attribute): Handle case of
	Discard_Names.
	* sem_attr.adb (Eval_Attribute, case Width): Ditto.

2011-11-21  Thomas Quinot  <quinot@adacore.com>

	* sinfo.ads: Minor reformatting.

2011-11-21  Yannick Moy  <moy@adacore.com>

	* exp_util.adb: Minor reformatting. Update comments.



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

4 files changed, 146 insertions, 33 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 6b23472e32f..65cb5e92cf4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,19 @@
 2011-11-21  Robert Dewar  <dewar@adacore.com>
 
+	* exp_imgv.adb (Expand_Width_Attribute): Handle case of
+	Discard_Names.
+	* sem_attr.adb (Eval_Attribute, case Width): Ditto.
+
+2011-11-21  Thomas Quinot  <quinot@adacore.com>
+
+	* sinfo.ads: Minor reformatting.
+
+2011-11-21  Yannick Moy  <moy@adacore.com>
+
+	* exp_util.adb: Minor reformatting. Update comments.
+
+2011-11-21  Robert Dewar  <dewar@adacore.com>
+
 	* exp_prag.adb, exp_util.adb, sinfo.ads, sem_res.adb, s-stposu.adb,
 	sem_attr.adb, s-stposu.ads, s-taprop-solaris.adb, s-taprop-irix.adb,
 	sem_ch6.adb: Minor reformatting.
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 1c46950a952..14443b0ef88 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -27,7 +27,6 @@ with Atree;    use Atree;
 with Casing;   use Casing;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
-with Errout;   use Errout;
 with Exp_Util; use Exp_Util;
 with Lib;      use Lib;
 with Namet;    use Namet;
@@ -246,7 +245,10 @@ package body Exp_Imgv is
    --  Snn (1 .. Pnn) then occurs as in the other cases. A special case is
    --  when pragma Discard_Names applies, in which case we replace expr by:
 
-   --    Missing ???
+   --     (rt'pos (expr))'Img
+
+   --  So that the result is a space followed by the decimal value for the
+   --  position of the enumeration value in the enumeration type.
 
    procedure Expand_Image_Attribute (N : Node_Id) is
       Loc       : constant Source_Ptr := Sloc (N);
@@ -369,7 +371,7 @@ package body Exp_Imgv is
            or else No (Lit_Strings (Root_Type (Ptyp)))
          then
             --  When pragma Discard_Names applies to the first subtype, build
-            --  (Pref'Pos)'Img.
+            --  (Pref'Pos (Expr))'Img.
 
             Rewrite (N,
               Make_Attribute_Reference (Loc,
@@ -1056,9 +1058,14 @@ package body Exp_Imgv is
    --                   typ'Pos (Typ'Last))
    --                   Wide_Character_Encoding_Method);
 
-   --  where typS and typI are the enumeration image strings and
-   --  indexes table, as described in Build_Enumeration_Image_Tables.
-   --  NN is 8/16/32 for depending on the element type for typI.
+   --  where typS and typI are the enumeration image strings and indexes
+   --  table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
+   --  for depending on the element type for typI.
+
+   --  Finally if Discard_Names is in effect for an enumeration type, then
+   --  a special conditional expression is built that yields the space needed
+   --  for the decimal representation of the largest pos value in the subtype.
+   --  See code below for details.
 
    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
       Loc     : constant Source_Ptr := Sloc (N);
@@ -1126,7 +1133,6 @@ package body Exp_Imgv is
       --  Real types
 
       elsif Is_Real_Type (Rtyp) then
-
          Rewrite (N,
            Make_Conditional_Expression (Loc,
              Expressions => New_List (
@@ -1156,29 +1162,116 @@ package body Exp_Imgv is
       else
          pragma Assert (Is_Enumeration_Type (Rtyp));
 
-         --  Whenever pragma Discard_Names is in effect, it suppresses the
-         --  generation of string literals for enumeration types. Since the
-         --  literals are required to evaluate the 'Width of an enumeration
-         --  type, emit an error.
+         --  Whenever pragma Discard_Names is in effect, the value we need
+         --  is the value needed to accomodate the largest integer pos value
+         --  in the range of the subtype + 1 for the space at the start. We
+         --  build:
 
-         --  ??? This is fine for configurable runtimes, but dubious in the
-         --  general case. For now keep both error messages until this issue
-         --  has been verified with the ARG.
+         --     Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
 
-         if Discard_Names (Rtyp) then
-            Error_Msg_Name_1 := Attribute_Name (N);
+         --  and replace the expression by
 
-            if Configurable_Run_Time_Mode then
-               Error_Msg_N ("attribute % not supported in configurable " &
-                            "run-time mode", N);
-            else
-               Error_Msg_N ("attribute % not supported when pragma " &
-                            "Discard_Names is in effect", N);
-            end if;
+         --     (if Ptyp'Range_Length = 0 then 0
+         --      else (if Tnn < 10 then 2
+         --            else (if Tnn < 100 then 3
+         --                  ...
+         --                      else n)))...
 
-            return;
+         --  where n is equal to Rtyp'Pos (Rtyp'Last) + 1
+
+         --  Note: The above processing is in accordance with the intent of
+         --  the RM, which is that Width should be related to the impl-defined
+         --  behavior of Image. It is not clear what this means if Image is
+         --  not defined (as in the configurable run-time case for GNAT) and
+         --  gives an error at compile time.
+
+         --  We choose in this case to just go ahead and implement Width the
+         --  same way, returning what Image would have returned if it has been
+         --  available in the configurable run-time library.
+
+         if Discard_Names (Rtyp) then
+            declare
+               Tnn : constant Entity_Id :=
+                       Make_Defining_Identifier (Loc,
+                         Chars => New_Internal_Name ('T'));
+
+               Cexpr : Node_Id;
+               P     : Int;
+               M     : Int;
+               K     : Int;
+
+            begin
+               Insert_Action (N,
+                 Make_Object_Declaration (Loc,
+                   Defining_Identifier => Tnn,
+                   Constant_Present    => True,
+                   Object_Definition   =>
+                     New_Occurrence_Of (Standard_Integer, Loc),
+                   Expression =>
+                     Make_Attribute_Reference (Loc,
+                       Prefix            => New_Occurrence_Of (Rtyp, Loc),
+                       Attribute_Name    => Name_Pos,
+                       Expressions       => New_List (
+                         Make_Attribute_Reference (Loc,
+                           Prefix            => New_Occurrence_Of (Ptyp, Loc),
+                           Attribute_Name    => Name_Last)))));
+
+               --  OK, now we need to build the conditional expression. First
+               --  get the value of M, the largest possible value needed.
+
+               P := UI_To_Int
+                      (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
+
+               K := 1;
+               M := 1;
+               while M < P loop
+                  M := M * 10;
+                  K := K + 1;
+               end loop;
+
+               --  Build inner else
+
+               Cexpr := Make_Integer_Literal (Loc, K);
+
+               --  Wrap in inner if's until counted down to 2
+
+               while K > 2 loop
+                  M := M / 10;
+                  K := K - 1;
+
+                  Cexpr :=
+                    Make_Conditional_Expression (Loc,
+                      Expressions => New_List (
+                        Make_Op_Lt (Loc,
+                          Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
+                          Right_Opnd => Make_Integer_Literal (Loc, M)),
+                        Make_Integer_Literal (Loc, K),
+                        Cexpr));
+               end loop;
+
+               --  Add initial comparison for null range and we are done, so
+               --  rewrite the attribute occurrence with this expression.
+
+               Rewrite (N,
+                 Convert_To (Typ,
+                   Make_Conditional_Expression (Loc,
+                     Expressions => New_List (
+                       Make_Op_Eq (Loc,
+                         Left_Opnd  =>
+                           Make_Attribute_Reference (Loc,
+                             Prefix         => New_Occurrence_Of (Ptyp, Loc),
+                             Attribute_Name => Name_Range_Length),
+                         Right_Opnd => Make_Integer_Literal (Loc, 0)),
+                       Make_Integer_Literal (Loc, 0),
+                       Cexpr))));
+
+               Analyze_And_Resolve (N, Typ);
+               return;
+            end;
          end if;
 
+         --  Normal case, not Discard_Names
+
          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 
          case Attr is
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 8b6613dfa2e..83506f08ff7 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6420,23 +6420,29 @@ package body Exp_Util is
    --  Start of processing for Remove_Side_Effects
 
    begin
-      --  Handle cases in which there is nothing to do. In particular,
-      --  side-effects are not removed in Alfa mode for formal verification.
-      --  Instead, formal verification is performed only on those expressions
-      --  provably side-effect free.
-
-      --  Why? Is the Alfa mode test just an optimization? Most likely not,
-      --  most likely it is functionally necessary, if so why ???
+      --  We only need to do removal of side effects if we are generating
+      --  actual code. That's because the whole issue of side effects is purely
+      --  a run-time issue, and the removal is required only to get proper
+      --  behavior at run-time.
+
+      --  In the Alfa case, we don't need to remove side effects because we
+      --  only perform formal verification is performed only on expressions
+      --  that are provably side-effect free. If we tried to remove side
+      --  effects in the Alfa case, we would get into a mess since in the case
+      --  of limited types in particular, removal of side effects involves the
+      --  use of access types or references which are not permitted in Alfa
+      --  mode.
 
       if not Full_Expander_Active then
          return;
+      end if;
 
       --  Cannot generate temporaries if the invocation to remove side effects
       --  was issued too early and the type of the expression is not resolved
       --  (this happens because routines Duplicate_Subexpr_XX implicitly invoke
       --  Remove_Side_Effects).
 
-      elsif No (Exp_Type)
+      if No (Exp_Type)
         or else Ekind (Exp_Type) = E_Access_Attribute_Type
       then
          return;
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 56604e17079..7e308ec328e 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -761,7 +761,7 @@ package Sinfo is
    --    if there is no corresponding spec, as in the case of a subprogram body
    --    that serves as its own spec.
    --
-   --    In Ada2012, Corresponding_Spec is set on expression functions that
+   --    In Ada 2012, Corresponding_Spec is set on expression functions that
    --    complete a subprogram declaration.
 
    --  Corresponding_Stub (Node3-Sem)