2009-04-27 Basile Starynkevitch <basile@starynkevitch.net>

	MERGED WITH TRUNK r146824::
	* gcc/basilys.h: all GTY goes before the identifiers.
	* gcc/basilys.c: removed errors.h include.
	* gcc/run-basilys.h: ditto.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@146839 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 129 insertions, 14 deletions

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 6a77fd1160c..d4545c0a1e5 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -46,10 +46,12 @@ with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sdefault; use Sdefault;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
 with Sem_Cat;  use Sem_Cat;
 with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Dist; use Sem_Dist;
+with Sem_Elim; use Sem_Elim;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Type; use Sem_Type;
@@ -572,6 +574,10 @@ package body Sem_Attr is
                Error_Attr ("attribute% cannot be applied to a subprogram", P);
             end if;
 
+            --  Issue an error if the prefix denotes an eliminated subprogram
+
+            Check_For_Eliminated_Subprogram (P, Entity (P));
+
             --  Build the appropriate subprogram type
 
             Build_Access_Subprogram_Type (P);
@@ -713,8 +719,7 @@ package body Sem_Attr is
                then
                   null;
 
-               --  OK if reference to the current instance of a protected
-               --  object.
+               --  OK if reference to current instance of a protected object
 
                elsif Is_Protected_Self_Reference (P) then
                   null;
@@ -1555,7 +1560,19 @@ package body Sem_Attr is
             end if;
          end if;
 
-         --  Check for violation of restriction No_Stream_Attributes
+         --  Check restriction violations
+
+         --  First check the No_Streams restriction, which prohibits the use
+         --  of explicit stream attributes in the source program. We do not
+         --  prevent the occurrence of stream attributes in generated code,
+         --  for instance those generated implicitly for dispatching purposes.
+
+         if Comes_From_Source (N) then
+            Check_Restriction (No_Streams, P);
+         end if;
+
+         --  Check special case of Exception_Id and Exception_Occurrence which
+         --  are not allowed for restriction No_Exception_Regstriation.
 
          if Is_RTE (P_Type, RE_Exception_Id)
               or else
@@ -1651,8 +1668,8 @@ package body Sem_Attr is
 
          elsif Is_Protected_Self_Reference (P) then
             Error_Attr_P
-              ("prefix of % attribute denotes current instance " &
-                 "(RM 9.4(21/2))");
+              ("prefix of % attribute denotes current instance "
+               & "(RM 9.4(21/2))");
 
          elsif Ekind (Entity (P)) = E_Incomplete_Type
             and then Present (Full_View (Entity (P)))
@@ -2021,8 +2038,8 @@ package body Sem_Attr is
          --  applies to other entity-denoting expressions.
 
          if Is_Protected_Self_Reference (P) then
-            --  An Address attribute on a protected object self reference
-            --  is legal.
+
+            --  Address attribute on a protected object self reference is legal
 
             null;
 
@@ -2047,6 +2064,28 @@ package body Sem_Attr is
                      Error_Attr_P
                        ("prefix of % attribute cannot be Inline_Always" &
                         " subprogram");
+
+                  --  It is illegal to apply 'Address to an intrinsic
+                  --  subprogram. This is now formalized in AI05-0095.
+                  --  In an instance, an attempt to obtain 'Address of an
+                  --  intrinsic subprogram (e.g the renaming of a predefined
+                  --  operator that is an actual) raises Program_Error.
+
+                  elsif Convention (Ent) = Convention_Intrinsic then
+                     if In_Instance then
+                        Rewrite (N,
+                          Make_Raise_Program_Error (Loc,
+                            Reason => PE_Address_Of_Intrinsic));
+
+                     else
+                        Error_Msg_N
+                         ("cannot take Address of intrinsic subprogram", N);
+                     end if;
+
+                  --  Issue an error if prefix denotes an eliminated subprogram
+
+                  else
+                     Check_For_Eliminated_Subprogram (P, Ent);
                   end if;
 
                elsif Is_Object (Ent)
@@ -2487,6 +2526,11 @@ package body Sem_Attr is
          then
             Error_Attr ("invalid prefix for % attribute", P);
             Set_Address_Taken (Entity (P));
+
+         --  Issue an error if the prefix denotes an eliminated subprogram
+
+         else
+            Check_For_Eliminated_Subprogram (P, Entity (P));
          end if;
 
          Set_Etype (N, RTE (RE_Address));
@@ -3825,7 +3869,7 @@ package body Sem_Attr is
             end if;
 
          --  Body case, where we must be inside a generated _Postcondition
-         --  procedure, and the prefix must be on the scope stack,  or else
+         --  procedure, and the prefix must be on the scope stack, or else
          --  the attribute use is definitely misplaced. The condition itself
          --  may have generated transient scopes, and is not necessarily the
          --  current one.
@@ -4840,7 +4884,7 @@ package body Sem_Attr is
 
          --  Check that result is in bounds of the type if it is static
 
-         if Is_In_Range (N, T) then
+         if Is_In_Range (N, T, Assume_Valid => False) then
             null;
 
          elsif Is_Out_Of_Range (N, T) then
@@ -5258,7 +5302,7 @@ package body Sem_Attr is
                if Present (AS) and then Is_Constrained (AS) then
                   P_Entity := AS;
 
-               --  If we have an unconstrained type, cannot fold
+               --  If we have an unconstrained type we cannot fold
 
                else
                   Check_Expressions;
@@ -5518,6 +5562,10 @@ package body Sem_Attr is
          --  Again we compute the variable Static for easy reference later
          --  (note that no array attributes are static in Ada 83).
 
+         --  We also need to set Static properly for subsequent legality checks
+         --  which might otherwise accept non-static constants in contexts
+         --  where they are not legal.
+
          Static := Ada_Version >= Ada_95
                      and then Statically_Denotes_Entity (P);
 
@@ -5526,6 +5574,16 @@ package body Sem_Attr is
 
          begin
             N := First_Index (P_Type);
+
+            --  The expression is static if the array type is constrained
+            --  by given bounds, and not by an initial expression. Constant
+            --  strings are static in any case.
+
+            if Root_Type (P_Type) /= Standard_String then
+               Static :=
+                 Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
+            end if;
+
             while Present (N) loop
                Static := Static and then Is_Static_Subtype (Etype (N));
 
@@ -6095,12 +6153,11 @@ package body Sem_Attr is
          Ind : Node_Id;
 
       begin
-         --  In the case of a generic index type, the bounds may
-         --  appear static but the computation is not meaningful,
-         --  and may generate a spurious warning.
+         --  In the case of a generic index type, the bounds may appear static
+         --  but the computation is not meaningful in this case, and may
+         --  generate a spurious warning.
 
          Ind := First_Index (P_Type);
-
          while Present (Ind) loop
             if Is_Generic_Type (Etype (Ind)) then
                return;
@@ -6111,6 +6168,8 @@ package body Sem_Attr is
 
          Set_Bounds;
 
+         --  For two compile time values, we can compute length
+
          if Compile_Time_Known_Value (Lo_Bound)
            and then Compile_Time_Known_Value (Hi_Bound)
          then
@@ -6118,6 +6177,33 @@ package body Sem_Attr is
               UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
               True);
          end if;
+
+         --  One more case is where Hi_Bound and Lo_Bound are compile-time
+         --  comparable, and we can figure out the difference between them.
+
+         declare
+            Diff : aliased Uint;
+
+         begin
+            case
+              Compile_Time_Compare
+                (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+            is
+               when EQ =>
+                  Fold_Uint (N, Uint_1, False);
+
+               when GT =>
+                  Fold_Uint (N, Uint_0, False);
+
+               when LT =>
+                  if Diff /= No_Uint then
+                     Fold_Uint (N, Diff + 1, False);
+                  end if;
+
+               when others =>
+                  null;
+            end case;
+         end;
       end Length;
 
       -------------
@@ -6609,6 +6695,8 @@ package body Sem_Attr is
       when Attribute_Range_Length =>
          Set_Bounds;
 
+         --  Can fold if both bounds are compile time known
+
          if Compile_Time_Known_Value (Hi_Bound)
            and then Compile_Time_Known_Value (Lo_Bound)
          then
@@ -6618,6 +6706,33 @@ package body Sem_Attr is
                  Static);
          end if;
 
+         --  One more case is where Hi_Bound and Lo_Bound are compile-time
+         --  comparable, and we can figure out the difference between them.
+
+         declare
+            Diff : aliased Uint;
+
+         begin
+            case
+              Compile_Time_Compare
+                (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
+            is
+               when EQ =>
+                  Fold_Uint (N, Uint_1, False);
+
+               when GT =>
+                  Fold_Uint (N, Uint_0, False);
+
+               when LT =>
+                  if Diff /= No_Uint then
+                     Fold_Uint (N, Diff + 1, False);
+                  end if;
+
+               when others =>
+                  null;
+            end case;
+         end;
+
       ---------------
       -- Remainder --
       ---------------