sem_attr.ads, [...] (Analyze_Attribute, case Value): For enumeration type, mark…

sem_attr.ads, [...] (Analyze_Attribute, case Value): For enumeration type, mark all literals as referenced.

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.ads, sem_attr.adb (Analyze_Attribute, case Value): For
	enumeration type, mark all literals as referenced.
	(Eval_Attribute, case 'Image): If the argument is an enumeration
	literal and names are available, constant-fold but mark nevertheless as
	non-static.
	Clean up function names.
	(Name_Modifies_Prefix): Rename to Name_Implies_Lvalue_Prefix. Clarify
	comment.
	(Requires_Simple_Name_Prefix): Removed.

From-SVN: r127425

gcc/ada/sem_attr.adb

@@ -27,6 +27,7 @@
 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
 
 with Atree;    use Atree;
+with Casing;   use Casing;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
@@ -136,27 +137,18 @@ package body Sem_Attr is
       Attribute_Wide_Wide_Width   => True,
       others                      => False);
 
-   --  The following array contains all attributes that cause a modification
-   --  of their prefixes. In a certain sense, the prefix may be considered as
-   --  an lvalue.
+   --  The following array contains all attributes that imply a modification
+   --  of their prefixes or result in an access value. Such prefixes can be
+   --  considered as lvalues.
 
-   Attribute_Name_Modifies_Prefix : constant Attribute_Class_Array :=
+   Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
       Attribute_Class_Array'(
       Attribute_Access              |
       Attribute_Address             |
       Attribute_Input               |
       Attribute_Read                |
-      Attribute_Unchecked_Access => True,
-      others                     => False);
-
-   --  The following list contains all attributes that require simple names
-   --  rather than values as their prefixes.
-
-   Attribute_Requires_Simple_Name_Prefix : constant Attribute_Class_Array :=
-      Attribute_Class_Array'(
-      Attribute_Asm_Input  |
-      Attribute_Asm_Output |
-      Attribute_Size       => True,
+      Attribute_Unchecked_Access    |
+      Attribute_Unrestricted_Access => True,
       others                        => False);
 
    -----------------------
@@ -1638,86 +1630,6 @@ package body Sem_Attr is
       procedure Standard_Attribute (Val : Int) is
       begin
          Check_Standard_Prefix;
-
-         --  First a special check (more like a kludge really). For GNAT5
-         --  on Windows, the alignments in GCC are severely mixed up. In
-         --  particular, we have a situation where the maximum alignment
-         --  that GCC thinks is possible is greater than the guaranteed
-         --  alignment at run-time. That causes many problems. As a partial
-         --  cure for this situation, we force a value of 4 for the maximum
-         --  alignment attribute on this target. This still does not solve
-         --  all problems, but it helps.
-
-         --  A further (even more horrible) dimension to this kludge is now
-         --  installed. There are two uses for Maximum_Alignment, one is to
-         --  determine the maximum guaranteed alignment, that's the one we
-         --  want the kludge to yield as 4. The other use is to maximally
-         --  align objects, we can't use 4 here, since for example, long
-         --  long integer has an alignment of 8, so we will get errors.
-
-         --  It is of course impossible to determine which use the programmer
-         --  has in mind, but an approximation for now is to disconnect the
-         --  kludge if the attribute appears in an alignment clause.
-
-         --  To be removed if GCC ever gets its act together here ???
-
-         Alignment_Kludge : declare
-            P : Node_Id;
-
-            function On_X86 return Boolean;
-            --  Determine if target is x86 (ia32), return True if so
-
-            ------------
-            -- On_X86 --
-            ------------
-
-            function On_X86 return Boolean is
-               T : constant String := Sdefault.Target_Name.all;
-
-            begin
-               --  There is no clean way to check this. That's not surprising,
-               --  the front end should not be doing this kind of test ???. The
-               --  way we do it is test for either "86" or "pentium" being in
-               --  the string for the target name. However, we need to exclude
-               --  x86_64 for this check.
-
-               for J in T'First .. T'Last - 1 loop
-                  if (T (J .. J + 1) = "86"
-                      and then
-                        (J + 4 > T'Last
-                           or else T (J + 2 .. J + 4) /= "_64"))
-                    or else (J <= T'Last - 6
-                               and then T (J .. J + 6) = "pentium")
-                  then
-                     return True;
-                  end if;
-               end loop;
-
-               return False;
-            end On_X86;
-
-         --  Start of processing for Alignment_Kludge
-
-         begin
-            if Aname = Name_Maximum_Alignment and then On_X86 then
-               P := Parent (N);
-
-               while Nkind (P) in N_Subexpr loop
-                  P := Parent (P);
-               end loop;
-
-               if Nkind (P) /= N_Attribute_Definition_Clause
-                 or else Chars (P) /= Name_Alignment
-               then
-                  Rewrite (N, Make_Integer_Literal (Loc, 4));
-                  Analyze (N);
-                  return;
-               end if;
-            end if;
-         end Alignment_Kludge;
-
-         --  Normally we get the value from gcc ???
-
          Rewrite (N, Make_Integer_Literal (Loc, Val));
          Analyze (N);
       end Standard_Attribute;
@@ -1791,15 +1703,17 @@ package body Sem_Attr is
       end if;
 
       --  Analyze prefix and exit if error in analysis. If the prefix is an
-      --  incomplete type, use full view if available. A special case is
-      --  that we never analyze the prefix of an Elab_Body or Elab_Spec
-      --  or UET_Address attribute.
+      --  incomplete type, use full view if available. Note that there are
+      --  some attributes for which we do not analyze the prefix, since the
+      --  prefix is not a normal name.
 
       if Aname /= Name_Elab_Body
            and then
          Aname /= Name_Elab_Spec
            and then
          Aname /= Name_UET_Address
+           and then
+         Aname /= Name_Enabled
       then
          Analyze (P);
          P_Type := Etype (P);
@@ -1864,7 +1778,7 @@ package body Sem_Attr is
          E1 := First (Exprs);
          Analyze (E1);
 
-         --  Check for missing or bad expression (result of previous error)
+         --  Check for missing/bad expression (result of previous error)
 
          if No (E1) or else Etype (E1) = Any_Type then
             raise Bad_Attribute;
@@ -1886,7 +1800,7 @@ package body Sem_Attr is
       end if;
 
       --  Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
-      --  output compiling in Ada 95 mode
+      --  output compiling in Ada 95 mode for the case of ambiguous prefixes.
 
       if Ada_Version < Ada_05
         and then Is_Overloaded (P)
@@ -2371,7 +2285,6 @@ package body Sem_Attr is
       --  immediately and sets an appropriate type.
 
       when Attribute_Bit_Position =>
-
          if Comes_From_Source (N) then
             Check_Component;
          end if;
@@ -2564,7 +2477,7 @@ package body Sem_Attr is
             if Warn_On_Obsolescent_Feature then
                Error_Msg_N
                  ("constrained for private type is an " &
-                  "obsolescent feature ('R'M 'J.4)?", N);
+                  "obsolescent feature (RM J.4)?", N);
             end if;
 
             --  If we are within an instance, the attribute must be legal
@@ -2605,7 +2518,7 @@ package body Sem_Attr is
             end if;
 
             --  Must have discriminants or be an access type designating
-            --  a type with discriminants. If it is a classwide type is
+            --  a type with discriminants. If it is a classwide type is ???
             --  has unknown discriminants.
 
             if Has_Discriminants (P_Type)
@@ -2872,6 +2785,29 @@ package body Sem_Attr is
          Check_Floating_Point_Type_0;
          Set_Etype (N, Universal_Integer);
 
+      -------------
+      -- Enabled --
+      -------------
+
+      when Attribute_Enabled =>
+         Check_Either_E0_Or_E1;
+
+         if Present (E1) then
+            if not Is_Entity_Name (E1) or else No (Entity (E1)) then
+               Error_Msg_N ("entity name expected for Enabled attribute", E1);
+               E1 := Empty;
+            end if;
+         end if;
+
+         if Nkind (P) /= N_Identifier then
+            Error_Msg_N ("identifier expected (check name)", P);
+
+         elsif Get_Check_Id (Chars (P)) = No_Check_Id then
+            Error_Msg_N ("& is not a recognized check name", P);
+         end if;
+
+         Set_Etype (N, Standard_Boolean);
+
       --------------
       -- Enum_Rep --
       --------------
@@ -4223,8 +4159,23 @@ package body Sem_Attr is
          Check_E1;
          Check_Scalar_Type;
 
+         --  Case of enumeration type
+
          if Is_Enumeration_Type (P_Type) then
             Check_Restriction (No_Enumeration_Maps, N);
+
+            --  Mark all enumeration literals as referenced, since the use of
+            --  the Value attribute can implicitly reference any of the
+            --  literals of the enumeration base type.
+
+            declare
+               Ent : Entity_Id := First_Literal (P_Base_Type);
+            begin
+               while Present (Ent) loop
+                  Set_Referenced (Ent);
+                  Next_Literal (Ent);
+               end loop;
+            end;
          end if;
 
          --  Set Etype before resolving expression because expansion of
@@ -4507,7 +4458,6 @@ package body Sem_Attr is
       begin
          Result := 1;
          Delta_Val := Delta_Value (P_Type);
-
          while Delta_Val < Ureal_Tenth loop
             Delta_Val := Delta_Val * Ureal_10;
             Result := Result + 1;
@@ -4521,9 +4471,9 @@ package body Sem_Attr is
       -----------------------
 
       procedure Check_Expressions is
-         E : Node_Id := E1;
-
+         E : Node_Id;
       begin
+         E := E1;
          while Present (E) loop
             Check_Non_Static_Context (E);
             Next (E);
@@ -4886,6 +4836,49 @@ package body Sem_Attr is
          E2 := Empty;
       end if;
 
+      --  Special processing for Enabled attribute. This attribute has a very
+      --  special prefix, and the easiest way to avoid lots of special checks
+      --  to protect this special prefix from causing trouble is to deal with
+      --  this attribute immediately and be done with it.
+
+      if Id = Attribute_Enabled then
+
+         --  Evaluate the Enabled attribute
+
+         --  We skip evaluation if the expander is not active. This is not just
+         --  an optimization. It is of key importance that we not rewrite the
+         --  attribute in a generic template, since we want to pick up the
+         --  setting of the check in the instance, and testing expander active
+         --  is as easy way of doing this as any.
+
+         if Expander_Active then
+            declare
+               C : constant Check_Id := Get_Check_Id (Chars (P));
+               R : Boolean;
+
+            begin
+               if No (E1) then
+                  if C in Predefined_Check_Id then
+                     R := Scope_Suppress (C);
+                  else
+                     R := Is_Check_Suppressed (Empty, C);
+                  end if;
+
+               else
+                  R := Is_Check_Suppressed (Entity (E1), C);
+               end if;
+
+               if R then
+                  Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+               else
+                  Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+               end if;
+            end;
+         end if;
+
+         return;
+      end if;
+
       --  Special processing for cases where the prefix is an object. For
       --  this purpose, a string literal counts as an object (attributes
       --  of string literals can only appear in generated code).
@@ -5578,9 +5571,29 @@ package body Sem_Attr is
 
       --  Image is a scalar attribute, but is never static, because it is
       --  not a static function (having a non-scalar argument (RM 4.9(22))
+      --  However, we can constant-fold the image of an enumeration literal
+      --  if names are available.
 
       when Attribute_Image =>
-         null;
+         if Is_Entity_Name (E1)
+           and then Ekind (Entity (E1)) = E_Enumeration_Literal
+           and then not Discard_Names (First_Subtype (Etype (E1)))
+           and then not Global_Discard_Names
+         then
+            declare
+               Lit : constant Entity_Id := Entity (E1);
+               Str : String_Id;
+            begin
+               Start_String;
+               Get_Unqualified_Decoded_Name_String (Chars (Lit));
+               Set_Casing (All_Upper_Case);
+               Store_String_Chars (Name_Buffer (1 .. Name_Len));
+               Str := End_String;
+               Rewrite (N, Make_String_Literal (Loc, Strval => Str));
+               Analyze_And_Resolve (N, Standard_String);
+               Set_Is_Static_Expression (N, False);
+            end;
+         end if;
 
       ---------
       -- Img --
@@ -6644,12 +6657,10 @@ package body Sem_Attr is
 
       when Attribute_Value_Size => Value_Size : declare
          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
-
       begin
          if RM_Size (P_TypeA) /= Uint_0 then
             Fold_Uint (N, RM_Size (P_TypeA), True);
          end if;
-
       end Value_Size;
 
       -------------
@@ -6947,6 +6958,7 @@ package body Sem_Attr is
            Attribute_Elaborated               |
            Attribute_Elab_Body                |
            Attribute_Elab_Spec                |
+           Attribute_Enabled                  |
            Attribute_External_Tag             |
            Attribute_First_Bit                |
            Attribute_Input                    |
@@ -7011,7 +7023,6 @@ package body Sem_Attr is
       else
          null;
       end if;
-
    end Eval_Attribute;
 
    ------------------------------
@@ -7030,25 +7041,15 @@ package body Sem_Attr is
           and then Associated_Node_For_Itype (Anon) = Parent (Typ);
    end Is_Anonymous_Tagged_Base;
 
-   --------------------------
-   -- Name_Modifies_Prefix --
-   --------------------------
-
-   function Name_Modifies_Prefix (Nam : Name_Id) return Boolean is
-      pragma Assert (Is_Attribute_Name (Nam));
-   begin
-      return Attribute_Name_Modifies_Prefix (Get_Attribute_Id (Nam));
-   end Name_Modifies_Prefix;
-
-   ---------------------------------
-   -- Requires_Simple_Name_Prefix --
-   ---------------------------------
+   --------------------------------
+   -- Name_Implies_Lvalue_Prefix --
+   --------------------------------
 
-   function Requires_Simple_Name_Prefix (Nam : Name_Id) return Boolean is
+   function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
       pragma Assert (Is_Attribute_Name (Nam));
    begin
-      return Attribute_Requires_Simple_Name_Prefix (Get_Attribute_Id (Nam));
-   end Requires_Simple_Name_Prefix;
+      return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
+   end Name_Implies_Lvalue_Prefix;
 
    -----------------------
    -- Resolve_Attribute --
@@ -7161,6 +7162,7 @@ package body Sem_Attr is
             | Attribute_Unchecked_Access
             | Attribute_Unrestricted_Access =>
 
+         Access_Attribute : begin
             if Is_Variable (P) then
                Note_Possible_Modification (P);
             end if;
@@ -7187,7 +7189,7 @@ package body Sem_Attr is
 
                --  If Prefix is a subprogram name, it is frozen by this
                --  reference:
-               --
+
                --    If it is a type, there is nothing to resolve.
                --    If it is an object, complete its resolution.
 
@@ -7357,12 +7359,12 @@ package body Sem_Attr is
                            Error_Msg_NE
                              ("\because " &
                               "access type & is declared outside " &
-                              "generic unit ('R'M 3.10.2(32))", N, Btyp);
+                              "generic unit (RM 3.10.2(32))", N, Btyp);
                         else
                            Error_Msg_NE
                              ("\because ancestor of " &
                               "access type & is declared outside " &
-                              "generic unit ('R'M 3.10.2(32))", N, Btyp);
+                              "generic unit (RM 3.10.2(32))", N, Btyp);
                         end if;
 
                         Error_Msg_NE
@@ -7524,9 +7526,8 @@ package body Sem_Attr is
                      P);
                end if;
 
-               --  Check the static matching rule of 3.10.2(27). The
-               --  nominal subtype of the prefix must statically
-               --  match the designated type.
+               --  Check static matching rule of 3.10.2(27). Nominal subtype
+               --  of the prefix must statically match the designated type.
 
                Nom_Subt := Etype (P);
 
@@ -7554,8 +7555,8 @@ package body Sem_Attr is
                if Is_Tagged_Type (Designated_Type (Typ)) then
 
                   --  If the attribute is in the context of an access
-                  --  parameter, then the prefix is allowed to be of
-                  --  the class-wide type (by AI-127).
+                  --  parameter, then the prefix is allowed to be of the
+                  --  class-wide type (by AI-127).
 
                   if Ekind (Typ) = E_Anonymous_Access_Type then
                      if not Covers (Designated_Type (Typ), Nom_Subt)
@@ -7594,7 +7595,7 @@ package body Sem_Attr is
                        ("type of prefix: & is not covered", P, Nom_Subt);
                      Error_Msg_FE
                        ("\by &, the expected designated type" &
-                           " ('R'M 3.10.2 (27))", P, Designated_Type (Typ));
+                           " (RM 3.10.2 (27))", P, Designated_Type (Typ));
                   end if;
 
                   if Is_Class_Wide_Type (Designated_Type (Typ))
@@ -7666,12 +7667,11 @@ package body Sem_Attr is
                then
                   Error_Msg_F ("context requires a protected subprogram", P);
 
-               --  Check accessibility of protected object against that
-               --  of the access type, but only on user code, because
-               --  the expander creates access references for handlers.
-               --  If the context is an anonymous_access_to_protected,
-               --  there are no accessibility checks either.
-               --  Omit check altogether for GNAT Unrestricted_Access.
+               --  Check accessibility of protected object against that of the
+               --  access type, but only on user code, because the expander
+               --  creates access references for handlers. If the context is an
+               --  anonymous_access_to_protected, there are no accessibility
+               --  checks either. Omit check entirely for Unrestricted_Access.
 
                elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
                  and then Comes_From_Source (N)
@@ -7726,6 +7726,11 @@ package body Sem_Attr is
                end if;
             end if;
 
+            if Is_Entity_Name (P) then
+               Set_Address_Taken (Entity (P));
+            end if;
+         end Access_Attribute;
+
          -------------
          -- Address --
          -------------
@@ -7734,6 +7739,7 @@ package body Sem_Attr is
          --  is not permitted here, since there is no context to resolve it.
 
          when Attribute_Address | Attribute_Code_Address =>
+         Address_Attribute : begin
 
             --  To be safe, assume that if the address of a variable is taken,
             --  it may be modified via this address, so note modification.
@@ -7776,6 +7782,11 @@ package body Sem_Attr is
                  New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
             end if;
 
+            if Is_Entity_Name (P) then
+               Set_Address_Taken (Entity (P));
+            end if;
+         end Address_Attribute;
+
          ---------------
          -- AST_Entry --
          ---------------
@@ -7845,6 +7856,16 @@ package body Sem_Attr is
          when Attribute_Elaborated =>
             null;
 
+         -------------
+         -- Enabled --
+         -------------
+
+         --  Prefix of Enabled attribute is a check name, which must be treated
+         --  specially and not touched by Resolve.
+
+         when Attribute_Enabled =>
+            null;
+
          --------------------
          -- Mechanism_Code --
          --------------------
@@ -8112,23 +8133,9 @@ package body Sem_Attr is
       end case;
 
       --  Normally the Freezing is done by Resolve but sometimes the Prefix
-      --  is not resolved, in which case the freezing must be done now. The
-      --  exception to this general rule is the use of 'Address with
-      --  subprograms (this is required by the backend to support the static
-      --  allocation of the dispatch tables).
+      --  is not resolved, in which case the freezing must be done now.
 
-      if Static_Dispatch_Tables
-        and then Nkind (P) in N_Has_Entity
-        and then not Is_Frozen (Entity (P))
-        and then Attr_Id = Attribute_Address
-        and then Is_Subprogram (Entity (P))
-        and then Is_Dispatching_Operation (Entity (P))
-      then
-         Set_Has_Delayed_Freeze (Entity (P));
-
-      else
       Freeze_Expression (P);
-      end if;
 
       --  Finally perform static evaluation on the attribute reference
 

gcc/ada/sem_attr.ads

@@ -542,18 +542,16 @@ package Sem_Attr is
    --  in appropriate contexts (i.e. in subtype marks, or as prefixes for
    --  other attributes).
 
-   function Name_Modifies_Prefix (Nam : Name_Id) return Boolean;
-   --  Determine whether the name of an attribute reference modifies the
-   --  contents of its prefix. "Read" is such an attribute.
-
-   function Requires_Simple_Name_Prefix (Nam : Name_Id) return Boolean;
-   --  Determine whether the name of an attribute reference requires a simple
-   --  name rather than a value as its prefix. Such prefixes do not need to be
-   --  optimized. For instance in the following example:
-   --     I : constant Integer := 5;
-   --     S : constant Integer := I'Size;
-   --  "Size" requires a simple name prefix since "5'Size" does not make
-   --  sense.
+   function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean;
+   --  Determine whether the name of an attribute reference categorizes its
+   --  prefix as an lvalue. The following attributes fall under this bracket
+   --  by directly or indirectly modifying their prefixes.
+   --     Access
+   --     Address
+   --     Input
+   --     Read
+   --     Unchecked_Access
+   --     Unrestricted_Access
 
    procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id);
    --  Performs type resolution of attribute. If the attribute yields a