From 23866a558215a58d57e6f2a4adb68bba377db3b7 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:40:45 +0000 Subject: [PATCH] 2007-08-14 Robert Dewar Ed Schonberg * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127425 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sem_attr.adb | 339 ++++++++++++++++++++++++++------------------------- gcc/ada/sem_attr.ads | 22 ++-- 2 files changed, 183 insertions(+), 178 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 7e5b835..a669e26 100644 --- a/gcc/ada/sem_attr.adb +++ b/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,28 +137,19 @@ 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, - others => False); + Attribute_Access | + Attribute_Address | + Attribute_Input | + Attribute_Read | + Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => True, + others => False); ----------------------- -- Local_Subprograms -- @@ -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 @@ -7460,9 +7462,9 @@ package body Sem_Attr is if not (Ekind (Btyp) = E_Access_Subprogram_Type or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type - or else (Is_Record_Type (Btyp) - and then - Present (Corresponding_Remote_Type (Btyp))) + or else (Is_Record_Type (Btyp) + and then + Present (Corresponding_Remote_Type (Btyp))) or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type or else Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type @@ -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. @@ -7756,7 +7762,7 @@ package body Sem_Attr is end if; if not Is_Entity_Name (P) - or else not Is_Overloadable (Entity (P)) + or else not Is_Overloadable (Entity (P)) then if not Is_Task_Type (Etype (P)) or else Nkind (P) = N_Explicit_Dereference @@ -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). - - 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)); + -- is not resolved, in which case the freezing must be done now. - else - Freeze_Expression (P); - end if; + Freeze_Expression (P); -- Finally perform static evaluation on the attribute reference diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 6e15eaf..1ca9039 100644 --- a/gcc/ada/sem_attr.ads +++ b/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 -- 2.7.4