exp_attr.adb (Expand_N_Attribute_Reference): Add error entry for Library_Level attribute (which should not survive to expansion)

2013-10-14  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Add error
	entry for Library_Level attribute (which should not survive
	to expansion)
	* gnat_rm.texi: Document attribute Library_Level
	* sem_attr.adb (Analyze_Attribute, case Library_Level): Implement
	this new attribute (Set_Boolean_Result): Replaces Set_Result
	(Check_Standard_Prefix): Document that Check_E0 is called
	(Check_System_Prefix): New procedure
	* snames.ads-tmpl: Add entry for Library_Level attribute

2013-10-14  Robert Dewar  <dewar@adacore.com>

	* exp_ch6.adb, sinfo.ads: Minor reformatting.
	* checks.adb (Overlap_Check): Use identifier casing in messages.

From-SVN: r203528

8 files changed, 138 insertions, 60 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 567d644..6c33943 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,22 @@
 2013-10-14  Robert Dewar  <dewar@adacore.com>
 
+	* exp_attr.adb (Expand_N_Attribute_Reference): Add error
+	entry for Library_Level attribute (which should not survive
+	to expansion)
+	* gnat_rm.texi: Document attribute Library_Level
+	* sem_attr.adb (Analyze_Attribute, case Library_Level): Implement
+	this new attribute (Set_Boolean_Result): Replaces Set_Result
+	(Check_Standard_Prefix): Document that Check_E0 is called
+	(Check_System_Prefix): New procedure
+	* snames.ads-tmpl: Add entry for Library_Level attribute
+
+2013-10-14  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch6.adb, sinfo.ads: Minor reformatting.
+	* checks.adb (Overlap_Check): Use identifier casing in messages.
+
+2013-10-14  Robert Dewar  <dewar@adacore.com>
+
 	* einfo.ads, einfo.adb (Default_Aspect_Component_Value): Is on base type
 	only.
 	* exp_aggr.adb (Expand_Array_Aggregate): Handle proper
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 29a1859..f968e20 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -24,6 +24,7 @@
 ------------------------------------------------------------------------------
 
 with Atree;    use Atree;
+with Casing;   use Casing;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
@@ -2189,7 +2190,9 @@ package body Checks is
          Formal_2 : Entity_Id;
          Check    : in out Node_Id)
       is
-         Cond : Node_Id;
+         Cond      : Node_Id;
+         ID_Casing : constant Casing_Type :=
+                       Identifier_Casing (Source_Index (Current_Sem_Unit));
 
       begin
          --  Generate:
@@ -2220,9 +2223,17 @@ package body Checks is
             end if;
 
             Store_String_Chars ("aliased parameters, actuals for """);
-            Store_String_Chars (Get_Name_String (Chars (Formal_1)));
+
+            Get_Name_String (Chars (Formal_1));
+            Set_Casing (ID_Casing);
+            Store_String_Chars (Name_Buffer (1 .. Name_Len));
+
             Store_String_Chars (""" and """);
-            Store_String_Chars (Get_Name_String (Chars (Formal_2)));
+
+            Get_Name_String (Chars (Formal_2));
+            Set_Casing (ID_Casing);
+            Store_String_Chars (Name_Buffer (1 .. Name_Len));
+
             Store_String_Chars (""" overlap");
 
             Insert_Action (Call,
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 0034767..1a6ad57 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6485,6 +6485,7 @@ package body Exp_Attr is
            Attribute_Has_Tagged_Values            |
            Attribute_Large                        |
            Attribute_Last_Valid                   |
+           Attribute_Library_Level                |
            Attribute_Lock_Free                    |
            Attribute_Machine_Emax                 |
            Attribute_Machine_Emin                 |
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 151d649..d1c4641 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -8084,8 +8084,9 @@ package body Exp_Ch6 is
       --  AI05-0073: If function has a controlling access result, check that
       --  the tag of the return value, if it is not null, matches designated
       --  type of return type.
-      --  The return expression is referenced twice in the code below, so
-      --  it must be made free of side effects. Given that different compilers
+
+      --  The return expression is referenced twice in the code below, so it
+      --  must be made free of side effects. Given that different compilers
       --  may evaluate these parameters in different order, both occurrences
       --  perform a copy.
 
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 3c62f3d..cc3f248 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -337,6 +337,7 @@ Implementation Defined Attributes
 * Attribute Integer_Value::
 * Attribute Invalid_Value::
 * Attribute Large::
+* Attribute Library_Level::
 * Attribute Loop_Entry::
 * Attribute Machine_Size::
 * Attribute Mantissa::
@@ -7842,6 +7843,7 @@ consideration, you should minimize the use of these attributes.
 * Attribute Integer_Value::
 * Attribute Invalid_Value::
 * Attribute Large::
+* Attribute Library_Level::
 * Attribute Loop_Entry::
 * Attribute Machine_Size::
 * Attribute Mantissa::
@@ -8341,6 +8343,31 @@ The @code{Large} attribute is provided for compatibility with Ada 83.  See
 the Ada 83 reference manual for an exact description of the semantics of
 this attribute.
 
+@node Attribute Library_Level
+@unnumberedsec Attribute Library_Level
+@findex Library_Level
+@noindent
+@noindent
+@code{Standard'Library_Level} (@code{Standard} is the only allowed
+prefix) returns a Boolean value which is True if the attribute is
+evaluated at the library level (e.g. with a package declaration),
+and false if evaluated elsewhere (e.g. within a subprogram body).
+In the case of generics, the value indicates the placement of
+the instantiation, not the template, and indeed the use of this
+attribute within a generic is the intended common application
+as shown in this example:
+
+@smallexample @c ada
+generic
+  ...
+package Gen is
+  pragma Compile_Time_Error
+    (not Standard'Library_Level,
+     "Gen can only be instantiated at library level");
+  ...
+end Gen;
+@end smallexample
+
 @node Attribute Loop_Entry
 @unnumberedsec Attribute Loop_Entry
 @findex Loop_Entry
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 44692e0..f235921 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -189,6 +189,11 @@ package body Sem_Attr is
    --  where therefore the prefix of the attribute does not match the enclosing
    --  scope.
 
+   procedure Set_Boolean_Result (N : Node_Id; B : Boolean);
+   --  Rewrites node N with an occurrence of either Standard_False or
+   --  Standard_True, depending on the value of the parameter B. The
+   --  result is marked as a static expression.
+
    -----------------------
    -- Analyze_Attribute --
    -----------------------
@@ -339,13 +344,17 @@ package body Sem_Attr is
       --  Verify that prefix of attribute N is a scalar type
 
       procedure Check_Standard_Prefix;
-      --  Verify that prefix of attribute N is package Standard
+      --  Verify that prefix of attribute N is package Standard. Also checks
+      --  that there are no arguments.
 
       procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
       --  Validity checking for stream attribute. Nam is the TSS name of the
       --  corresponding possible defined attribute function (e.g. for the
       --  Read attribute, Nam will be TSS_Stream_Read).
 
+      procedure Check_System_Prefix;
+      --  Verify that prefix of attribute N is package System
+
       procedure Check_PolyORB_Attribute;
       --  Validity checking for PolyORB/DSA attribute
 
@@ -1972,6 +1981,17 @@ package body Sem_Attr is
          Check_Not_CPP_Type;
       end Check_Stream_Attribute;
 
+      -------------------------
+      -- Check_System_Prefix --
+      -------------------------
+
+      procedure Check_System_Prefix is
+      begin
+         if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
+            Error_Attr ("only allowed prefix for % attribute is System", P);
+         end if;
+      end Check_System_Prefix;
+
       -----------------------
       -- Check_Task_Prefix --
       -----------------------
@@ -3663,6 +3683,21 @@ package body Sem_Attr is
          Check_Array_Type;
          Set_Etype (N, Universal_Integer);
 
+      -------------------
+      -- Library_Level --
+      -------------------
+
+      when Attribute_Library_Level =>
+         Check_E0;
+         Check_Standard_Prefix;
+
+         if not Inside_A_Generic then
+            Set_Boolean_Result (N,
+              Nearest_Dynamic_Scope (Current_Scope) = Standard_Standard);
+         end if;
+
+         Set_Etype (N, Standard_Boolean);
+
       ---------------
       -- Lock_Free --
       ---------------
@@ -4965,35 +5000,10 @@ package body Sem_Attr is
          U    : Node_Id;
          Unam : Unit_Name_Type;
 
-         procedure Set_Result (B : Boolean);
-         --  Replace restriction node by static constant False or True,
-         --  depending on the value of B.
-
-         ----------------
-         -- Set_Result --
-         ----------------
-
-         procedure Set_Result (B : Boolean) is
-         begin
-            if B then
-               Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
-            else
-               Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
-            end if;
-
-            Set_Is_Static_Expression (N);
-         end Set_Result;
-
-      --  Start of processing for Restriction_Set
-
       begin
          Check_E1;
          Analyze (P);
-
-         if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
-            Set_Result (False);
-            Error_Attr_P ("prefix of % attribute must be System");
-         end if;
+         Check_System_Prefix;
 
          --  No_Dependence case
 
@@ -5002,7 +5012,7 @@ package body Sem_Attr is
             U := Explicit_Actual_Parameter (E1);
 
             if not OK_No_Dependence_Unit_Name (U) then
-               Set_Result (False);
+               Set_Boolean_Result (N, False);
                Error_Attr;
             end if;
 
@@ -5013,14 +5023,14 @@ package body Sem_Attr is
                if Designate_Same_Unit (U, No_Dependences.Table (J).Unit)
                  and then No_Dependences.Table (J).Warn = False
                then
-                  Set_Result (True);
+                  Set_Boolean_Result (N, True);
                   return;
                end if;
             end loop;
 
             --  If not in the No_Dependence table, result is False
 
-            Set_Result (False);
+            Set_Boolean_Result (N, False);
 
             --  In this case, we must ensure that the binder will reject any
             --  other unit in the partition that sets No_Dependence for this
@@ -5043,29 +5053,29 @@ package body Sem_Attr is
 
          else
             if Nkind (E1) /= N_Identifier then
-               Set_Result (False);
+               Set_Boolean_Result (N, False);
                Error_Attr ("attribute % requires restriction identifier", E1);
 
             else
                R := Get_Restriction_Id (Process_Restriction_Synonyms (E1));
 
                if R = Not_A_Restriction_Id then
-                  Set_Result (False);
+                  Set_Boolean_Result (N, False);
                   Error_Msg_Node_1 := E1;
                   Error_Attr ("invalid restriction identifier &", E1);
 
                elsif R not in Partition_Boolean_Restrictions then
-                  Set_Result (False);
+                  Set_Boolean_Result (N, False);
                   Error_Msg_Node_1 := E1;
                   Error_Attr
                     ("& is not a boolean partition-wide restriction", E1);
                end if;
 
                if Restriction_Active (R) then
-                  Set_Result (True);
+                  Set_Boolean_Result (N, True);
                else
                   Check_Restriction (R, N);
-                  Set_Result (False);
+                  Set_Boolean_Result (N, False);
                end if;
             end if;
          end if;
@@ -5596,10 +5606,7 @@ package body Sem_Attr is
       begin
          Check_E1;
          Analyze (P);
-
-         if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then
-            Error_Attr_P ("prefix of % attribute must be System");
-         end if;
+         Check_System_Prefix;
 
          Generate_Reference (RTE (RE_Address), P);
          Analyze_And_Resolve (E1, Any_Integer);
@@ -6809,8 +6816,8 @@ package body Sem_Attr is
             return;
          end if;
 
-      --  Cases where P is not an object. Cannot do anything if P is
-      --  not the name of an entity.
+      --  Cases where P is not an object. Cannot do anything if P is not the
+      --  name of an entity.
 
       elsif not Is_Entity_Name (P) then
          Check_Expressions;
@@ -6908,10 +6915,9 @@ package body Sem_Attr is
 
       --  We can fold 'Alignment applied to a type if the alignment is known
       --  (as happens for an alignment from an attribute definition clause).
-      --  At this stage, this can happen only for types (e.g. record
-      --  types) for which the size is always non-static. We exclude
-      --  generic types from consideration (since they have bogus
-      --  sizes set within templates).
+      --  At this stage, this can happen only for types (e.g. record types) for
+      --  which the size is always non-static. We exclude generic types from
+      --  consideration (since they have bogus sizes set within templates).
 
       elsif Id = Attribute_Alignment
         and then Is_Type (P_Entity)
@@ -9118,6 +9124,7 @@ package body Sem_Attr is
            Attribute_First_Bit                  |
            Attribute_Input                      |
            Attribute_Last_Bit                   |
+           Attribute_Library_Level              |
            Attribute_Maximum_Alignment          |
            Attribute_Old                        |
            Attribute_Output                     |
@@ -10421,6 +10428,23 @@ package body Sem_Attr is
       Eval_Attribute (N);
    end Resolve_Attribute;
 
+   ------------------------
+   -- Set_Boolean_Result --
+   ------------------------
+
+   procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
+      Loc : constant Source_Ptr := Sloc (N);
+
+   begin
+      if B then
+         Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+      else
+         Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+      end if;
+
+      Set_Is_Static_Expression (N);
+   end Set_Boolean_Result;
+
    --------------------------------
    -- Stream_Attribute_Available --
    --------------------------------
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index c39f3c4..ebe51f2 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -7646,7 +7646,7 @@ package Sinfo is
       --  N_Subprogram_Info
       --  Sloc points to the entity for the procedure
       --  Identifier (Node1) identifier referencing the procedure
-      --  Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc
+      --  Etype (Node5-Sem) type (always set to Ada.Exceptions.Code_Loc)
 
       --  Note: in the case where a debug source file is generated, the Sloc
       --  for this node points to the quote in the Sprint file output.
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 5254b57..c5c4cda 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -807,20 +807,15 @@ package Snames is
 
    --  Names of recognized attributes. The entries with the comment "Ada 83"
    --  are attributes that are defined in Ada 83, but not in Ada 95. These
-   --  attributes are implemented in both Ada 83 and Ada 95 modes in GNAT.
+   --  attributes are implemented in all Ada modes in GNAT.
 
    --  The entries marked GNAT are attributes that are defined by GNAT and
-   --  implemented in both Ada 83 and Ada 95 modes. Full descriptions of these
-   --  implementation dependent attributes may be found in the appropriate
-   --  section in Sem_Attr.
+   --  implemented in all Ada modes. Full descriptions of these implementation
+   --  dependent attributes may be found in the appropriate Sem_Attr section.
 
    --  The entries marked VMS are recognized only in OpenVMS implementations
    --  of GNAT, and are treated as illegal in all other contexts.
 
-   --  The entries marked HiLite are attributes that are defined by Hi-Lite
-   --  and implemented in GNAT operating under formal verification mode. The
-   --  entries are treated as illegal in all other contexts.
-
    First_Attribute_Name                : constant Name_Id := N + $;
    Name_Abort_Signal                   : constant Name_Id := N + $; -- GNAT
    Name_Access                         : constant Name_Id := N + $;
@@ -881,8 +876,9 @@ package Snames is
    Name_Last_Valid                     : constant Name_Id := N + $; -- Ada 12
    Name_Leading_Part                   : constant Name_Id := N + $;
    Name_Length                         : constant Name_Id := N + $;
+   Name_Library_Level                  : constant Name_Id := N + $; -- GNAT
    Name_Lock_Free                      : constant Name_Id := N + $; -- GNAT
-   Name_Loop_Entry                     : constant Name_Id := N + $; -- HiLite
+   Name_Loop_Entry                     : constant Name_Id := N + $; -- GNAT
    Name_Machine_Emax                   : constant Name_Id := N + $;
    Name_Machine_Emin                   : constant Name_Id := N + $;
    Name_Machine_Mantissa               : constant Name_Id := N + $;
@@ -1498,6 +1494,7 @@ package Snames is
       Attribute_Last_Valid,
       Attribute_Leading_Part,
       Attribute_Length,
+      Attribute_Library_Level,
       Attribute_Lock_Free,
       Attribute_Loop_Entry,
       Attribute_Machine_Emax,