From b8dc622e9fc08c74a749eb81503f795363625d12 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 15 Feb 2006 10:43:54 +0100 Subject: [PATCH] sem_attr.adb (Analyze_Attribute): In case of 'Class applied to an abstract interface type call... 2006-02-13 Javier Miranda Ed Schonberg * sem_attr.adb (Analyze_Attribute): In case of 'Class applied to an abstract interface type call analyze_and_resolve to expand the type conversion into the corresponding displacement of the reference to the base of the object. (Eval_Attribute, case Width): For systems where IEEE extended precision is supported, the maximum exponent occupies 4 decimal digits. (Accessibility_Message): Add '\' in 2-line warning message. (Resolve_Attribute): Likewise. (case Attribute_Access): Significantly revise checks for illegal access-to-subprogram Access attributes to properly enforce the rules of 3.10.2(32/2). Diagnose use of current instance with an illegal attribute. * sem_util.ads, sem_util.adb (Enclosing_Generic_Body): Change formal to a Node_Id. (Enclosing_Generic_Unit): New function to return a node's innermost enclosing generic declaration node. (Compile_Time_Constraint_Error): Remove '!' in warning messages. (Type_Access_Level): The accessibility level of anonymous acccess types associated with discriminants is that of the current instance of the type, and that's deeper than the type itself (AARM 3.10.2 (12.3.21)). (Compile_Time_Constraint_Error): Handle case of conditional expression. (Kill_Current_Values_For_Entity): New function (Enter_Name): Change formal type to Entity_Id From-SVN: r111089 --- gcc/ada/sem_attr.adb | 212 +++++++++++++++++++++++++++++++++---------- gcc/ada/sem_util.adb | 171 +++++++++++++++++++++++++++------- gcc/ada/sem_util.ads | 27 ++++-- 3 files changed, 321 insertions(+), 89 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e0c05fd62ae..1a72883677e 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -56,7 +56,6 @@ with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; -with Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Ttypes; use Ttypes; @@ -1151,7 +1150,7 @@ package body Sem_Attr is end if; if Ekind (Typ) = E_Incomplete_Type - and then not Present (Full_View (Typ)) + and then No (Full_View (Typ)) then Error_Attr ("prefix of % attribute cannot be an incomplete type", P); @@ -1665,11 +1664,45 @@ package body Sem_Attr is if Is_Entity_Name (P) and then Present (Entity (P)) and then Is_Type (Entity (P)) - and then Ekind (Entity (P)) = E_Incomplete_Type then - P_Type := Get_Full_View (P_Type); - Set_Entity (P, P_Type); - Set_Etype (P, P_Type); + if Ekind (Entity (P)) = E_Incomplete_Type then + P_Type := Get_Full_View (P_Type); + Set_Entity (P, P_Type); + Set_Etype (P, P_Type); + + elsif Entity (P) = Current_Scope + and then Is_Record_Type (Entity (P)) + then + + -- Use of current instance within the type. Verify that if the + -- attribute appears within a constraint, it yields an access + -- type, other uses are illegal. + + declare + Par : Node_Id; + + begin + Par := Parent (N); + while Present (Par) + and then Nkind (Parent (Par)) /= N_Component_Definition + loop + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) = N_Subtype_Indication + then + if Attr_Id /= Attribute_Access + and then Attr_Id /= Attribute_Unchecked_Access + and then Attr_Id /= Attribute_Unrestricted_Access + then + Error_Msg_N + ("in a constraint the current instance can only" + & " be used with an access attribute", N); + end if; + end if; + end; + end if; end if; if P_Type = Any_Type then @@ -2274,6 +2307,8 @@ package body Sem_Attr is ----------- when Attribute_Class => Class : declare + P : constant Entity_Id := Prefix (N); + begin Check_Restriction (No_Dispatch, N); Check_Either_E0_Or_E1; @@ -2288,12 +2323,22 @@ package body Sem_Attr is Make_Type_Conversion (Loc, Subtype_Mark => Make_Attribute_Reference (Loc, - Prefix => Prefix (N), + Prefix => P, Attribute_Name => Name_Class), Expression => Relocate_Node (E1))); Save_Interps (E1, Expression (N)); - Analyze (N); + + if not Is_Interface (Etype (P)) then + Analyze (N); + + -- Ada 2005 (AI-251): In case of abstract interfaces we have to + -- analyze and resolve the type conversion to generate the code + -- that displaces the reference to the base of the object. + + else + Analyze_And_Resolve (N, Etype (P)); + end if; -- Otherwise we just need to find the proper type @@ -4725,10 +4770,10 @@ package body Sem_Attr is then P_Type := Etype (P_Entity); - -- If the entity is an array constant with an unconstrained - -- nominal subtype then get the type from the initial value. - -- If the value has been expanded into assignments, the expression - -- is not present and the attribute reference remains dynamic. + -- If the entity is an array constant with an unconstrained nominal + -- subtype then get the type from the initial value. If the value has + -- been expanded into assignments, there is no expression and the + -- attribute reference remains dynamic. -- We could do better here and retrieve the type ??? if Ekind (P_Entity) = E_Constant @@ -6447,7 +6492,8 @@ package body Sem_Attr is -- nnn is set to 2 for Short_Float and Float (32 bit -- floats), and 3 for Long_Float and Long_Long_Float. - -- This is not quite right, but is good enough. + -- For machines where Long_Long_Float is the IEEE + -- extended precision type, the exponent takes 4 digits. declare Len : Int := @@ -6456,8 +6502,10 @@ package body Sem_Attr is begin if Esize (P_Type) <= 32 then Len := Len + 6; - else + elsif Esize (P_Type) = 64 then Len := Len + 7; + else + Len := Len + 8; end if; Fold_Uint (N, UI_From_Int (Len), True); @@ -6782,7 +6830,7 @@ package body Sem_Attr is Error_Msg_N ("?non-local pointer cannot point to local object", P); Error_Msg_N - ("?Program_Error will be raised at run time", P); + ("\?Program_Error will be raised at run time", P); Rewrite (N, Make_Raise_Program_Error (Loc, Reason => PE_Accessibility_Check_Failed)); @@ -6953,12 +7001,13 @@ package body Sem_Attr is elsif Aname = Name_Unrestricted_Access then null; -- Nothing to check - -- Check the static accessibility rule of 3.10.2(32) - -- In an instance body, if subprogram and type are both - -- local, other rules prevent dangling references, and no - -- warning is needed. + -- Check the static accessibility rule of 3.10.2(32). + -- This rule also applies within the private part of an + -- instantiation. This rule does not apply to anonymous + -- access-to-subprogram types (Ada 2005). elsif Attr_Id = Attribute_Access + and then not In_Instance_Body and then Subprogram_Access_Level (Entity (P)) > Type_Access_Level (Btyp) and then Ekind (Btyp) /= @@ -6966,36 +7015,101 @@ package body Sem_Attr is and then Ekind (Btyp) /= E_Anonymous_Access_Protected_Subprogram_Type then - if not In_Instance_Body then - Error_Msg_N - ("subprogram must not be deeper than access type", - P); - - elsif Scope (Entity (P)) /= Scope (Btyp) then - Error_Msg_N - ("subprogram must not be deeper than access type?", - P); - Error_Msg_N - ("Constraint_Error will be raised ?", P); - Set_Raises_Constraint_Error (N); - end if; - - -- Check the restriction of 3.10.2(32) that disallows - -- the type of the access attribute to be declared - -- outside a generic body when the subprogram is declared - -- within that generic body. - - -- Ada2005: If the expected type is for an access - -- parameter, this clause does not apply. + Error_Msg_N + ("subprogram must not be deeper than access type", P); + + -- Check the restriction of 3.10.2(32) that disallows the + -- access attribute within a generic body when the ultimate + -- ancestor of the type of the attribute is declared outside + -- of the generic unit and the subprogram is declared within + -- that generic unit. This includes any such attribute that + -- occurs within the body of a generic unit that is a child + -- of the generic unit where the subprogram is declared. + -- The rule also prohibits applying the attibute when the + -- access type is a generic formal access type (since the + -- level of the actual type is not known). This restriction + -- does not apply when the attribute type is an anonymous + -- access-to-subprogram type. Note that this check was + -- revised by AI-229, because the originally Ada 95 rule + -- was too lax. The original rule only applied when the + -- subprogram was declared within the body of the generic, + -- which allowed the possibility of dangling references). + -- The rule was also too strict in some case, in that it + -- didn't permit the access to be declared in the generic + -- spec, whereas the revised rule does (as long as it's not + -- a formal type). + + -- There are a couple of subtleties of the test for applying + -- the check that are worth noting. First, we only apply it + -- when the levels of the subprogram and access type are the + -- same (the case where the subprogram is statically deeper + -- was applied above, and the case where the type is deeper + -- is always safe). Second, we want the check to apply + -- within nested generic bodies and generic child unit + -- bodies, but not to apply to an attribute that appears in + -- the generic unit's specification. This is done by testing + -- that the attribute's innermost enclosing generic body is + -- not the same as the innermost generic body enclosing the + -- generic unit where the subprogram is declared (we don't + -- want the check to apply when the access attribute is in + -- the spec and there's some other generic body enclosing + -- generic). Finally, there's no point applying the check + -- when within an instance, because any violations will + -- have been caught by the compilation of the generic unit. - elsif Present (Enclosing_Generic_Body (Entity (P))) - and then Enclosing_Generic_Body (Entity (P)) /= - Enclosing_Generic_Body (Btyp) - and then - Ekind (Btyp) /= E_Anonymous_Access_Subprogram_Type + elsif Attr_Id = Attribute_Access + and then not In_Instance + and then Present (Enclosing_Generic_Unit (Entity (P))) + and then Present (Enclosing_Generic_Body (N)) + and then Enclosing_Generic_Body (N) /= + Enclosing_Generic_Body + (Enclosing_Generic_Unit (Entity (P))) + and then Subprogram_Access_Level (Entity (P)) = + Type_Access_Level (Btyp) + and then Ekind (Btyp) /= + E_Anonymous_Access_Subprogram_Type + and then Ekind (Btyp) /= + E_Anonymous_Access_Protected_Subprogram_Type then - Error_Msg_N - ("access type must not be outside generic body", P); + -- The attribute type's ultimate ancestor must be + -- declared within the same generic unit as the + -- subprogram is declared. The error message is + -- specialized to say "ancestor" for the case where + -- the access type is not its own ancestor, since + -- saying simply "access type" would be very confusing. + + if Enclosing_Generic_Unit (Entity (P)) /= + Enclosing_Generic_Unit (Root_Type (Btyp)) + then + if Root_Type (Btyp) = Btyp then + Error_Msg_N + ("access type must not be outside generic unit", + N); + else + Error_Msg_N + ("ancestor access type must not be outside " & + "generic unit", N); + end if; + + -- If the ultimate ancestor of the attribute's type is + -- a formal type, then the attribute is illegal because + -- the actual type might be declared at a higher level. + -- The error message is specialized to say "ancestor" + -- for the case where the access type is not its own + -- ancestor, since saying simply "access type" would be + -- very confusing. + + elsif Is_Generic_Type (Root_Type (Btyp)) then + if Root_Type (Btyp) = Btyp then + Error_Msg_N + ("access type must not be a generic formal type", + N); + else + Error_Msg_N + ("ancestor access type must not be a generic " & + "formal type", N); + end if; + end if; end if; end if; @@ -7095,7 +7209,7 @@ package body Sem_Attr is Error_Msg_N ("?non-local pointer cannot point to local object", P); Error_Msg_N - ("?Program_Error will be raised at run time", P); + ("\?Program_Error will be raised at run time", P); Rewrite (N, Make_Raise_Program_Error (Loc, Reason => PE_Accessibility_Check_Failed)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ada7e636a3f..a9b64c70136 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -138,8 +138,8 @@ package body Sem_Util is Rtyp := Typ; end if; - Discard_Node ( - Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); + Discard_Node + (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn)); if not Rep then return; @@ -1103,6 +1103,7 @@ package body Sem_Util is Msgl : Natural; Wmsg : Boolean; P : Node_Id; + OldP : Node_Id; Msgs : Boolean; Eloc : Source_Ptr; @@ -1157,28 +1158,72 @@ package body Sem_Util is -- Should we generate a warning? The answer is not quite yes. The -- very annoying exception occurs in the case of a short circuit -- operator where the left operand is static and decisive. Climb - -- parents to see if that is the case we have here. + -- parents to see if that is the case we have here. Conditional + -- expressions with decisive conditions are a similar situation. Msgs := True; P := N; - loop + OldP := P; P := Parent (P); - if (Nkind (P) = N_And_Then - and then Compile_Time_Known_Value (Left_Opnd (P)) - and then Is_False (Expr_Value (Left_Opnd (P)))) - or else (Nkind (P) = N_Or_Else - and then Compile_Time_Known_Value (Left_Opnd (P)) - and then Is_True (Expr_Value (Left_Opnd (P)))) + -- And then with False as left operand + + if Nkind (P) = N_And_Then + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_False (Expr_Value (Left_Opnd (P))) then Msgs := False; exit; + -- OR ELSE with True as left operand + + elsif Nkind (P) = N_Or_Else + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_True (Expr_Value (Left_Opnd (P))) + then + Msgs := False; + exit; + + -- Conditional expression + + elsif Nkind (P) = N_Conditional_Expression then + declare + Cond : constant Node_Id := First (Expressions (P)); + Texp : constant Node_Id := Next (Cond); + Fexp : constant Node_Id := Next (Texp); + + begin + if Compile_Time_Known_Value (Cond) then + + -- Condition is True and we are in the right operand + + if Is_True (Expr_Value (Cond)) + and then OldP = Fexp + then + Msgs := False; + exit; + + -- Condition is False and we are in the left operand + + elsif Is_False (Expr_Value (Cond)) + and then OldP = Texp + then + Msgs := False; + exit; + end if; + end if; + end; + + -- Special case for component association in aggregates, where + -- we want to keep climbing up to the parent aggregate. + elsif Nkind (P) = N_Component_Association and then Nkind (Parent (P)) = N_Aggregate then - null; -- Keep going. + null; + + -- Keep going if within subexpression else exit when Nkind (P) not in N_Subexpr; @@ -1195,11 +1240,11 @@ package body Sem_Util is if Wmsg then if Inside_Init_Proc then Error_Msg_NEL - ("\& will be raised for objects of this type!?", + ("\?& will be raised for objects of this type", N, Standard_Constraint_Error, Eloc); else Error_Msg_NEL - ("\& will be raised at run time!?", + ("\?& will be raised at run time", N, Standard_Constraint_Error, Eloc); end if; else @@ -1536,15 +1581,14 @@ package body Sem_Util is ---------------------------- function Enclosing_Generic_Body - (E : Entity_Id) return Node_Id + (N : Node_Id) return Node_Id is P : Node_Id; Decl : Node_Id; Spec : Node_Id; begin - P := Parent (E); - + P := Parent (N); while Present (P) loop if Nkind (P) = N_Package_Body or else Nkind (P) = N_Subprogram_Body @@ -1568,6 +1612,47 @@ package body Sem_Util is return Empty; end Enclosing_Generic_Body; + ---------------------------- + -- Enclosing_Generic_Unit -- + ---------------------------- + + function Enclosing_Generic_Unit + (N : Node_Id) return Node_Id + is + P : Node_Id; + Decl : Node_Id; + Spec : Node_Id; + + begin + P := Parent (N); + while Present (P) loop + if Nkind (P) = N_Generic_Package_Declaration + or else Nkind (P) = N_Generic_Subprogram_Declaration + then + return P; + + elsif Nkind (P) = N_Package_Body + or else Nkind (P) = N_Subprogram_Body + then + Spec := Corresponding_Spec (P); + + if Present (Spec) then + Decl := Unit_Declaration_Node (Spec); + + if Nkind (Decl) = N_Generic_Package_Declaration + or else Nkind (Decl) = N_Generic_Subprogram_Declaration + then + return Decl; + end if; + end if; + end if; + + P := Parent (P); + end loop; + + return Empty; + end Enclosing_Generic_Unit; + ------------------------------- -- Enclosing_Lib_Unit_Entity -- ------------------------------- @@ -1660,7 +1745,7 @@ package body Sem_Util is -- Enter_Name -- ---------------- - procedure Enter_Name (Def_Id : Node_Id) is + procedure Enter_Name (Def_Id : Entity_Id) is C : constant Entity_Id := Current_Entity (Def_Id); E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; @@ -2450,7 +2535,7 @@ package body Sem_Util is Atyp : Entity_Id; begin - if not Present (Utyp) then + if No (Utyp) then Utyp := Typ; end if; @@ -5054,6 +5139,20 @@ package body Sem_Util is -- Kill_Current_Values -- ------------------------- + procedure Kill_Current_Values (Ent : Entity_Id) is + begin + if Is_Object (Ent) then + Kill_Checks (Ent); + Set_Current_Value (Ent, Empty); + + if not Can_Never_Be_Null (Ent) then + Set_Is_Known_Non_Null (Ent, False); + end if; + + Set_Is_Known_Null (Ent, False); + end if; + end Kill_Current_Values; + procedure Kill_Current_Values is S : Entity_Id; @@ -5066,18 +5165,10 @@ package body Sem_Util is procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is Ent : Entity_Id; - begin Ent := E; while Present (Ent) loop - if Is_Object (Ent) then - Set_Current_Value (Ent, Empty); - - if not Can_Never_Be_Null (Ent) then - Set_Is_Known_Non_Null (Ent, False); - end if; - end if; - + Kill_Current_Values (Ent); Next_Entity (Ent); end loop; end Kill_Current_Values_For_Entity_Chain; @@ -5570,6 +5661,7 @@ package body Sem_Util is -- side effects have been removed. Exp := Prefix (Expression (Parent (Entity (P)))); + goto Continue; else return; @@ -5581,22 +5673,22 @@ package body Sem_Util is or else Nkind (Exp) = N_Unchecked_Type_Conversion then Exp := Expression (Exp); + goto Continue; elsif Nkind (Exp) = N_Slice or else Nkind (Exp) = N_Indexed_Component or else Nkind (Exp) = N_Selected_Component then Exp := Prefix (Exp); + goto Continue; else return; - end if; -- Now look for entity being referenced if Present (Ent) then - if Is_Object (Ent) then if Comes_From_Source (Exp) or else Modification_Comes_From_Source @@ -5604,13 +5696,16 @@ package body Sem_Util is Set_Never_Set_In_Source (Ent, False); end if; - Set_Is_True_Constant (Ent, False); - Set_Current_Value (Ent, Empty); + Set_Is_True_Constant (Ent, False); + Set_Current_Value (Ent, Empty); + Set_Is_Known_Null (Ent, False); if not Can_Never_Be_Null (Ent) then Set_Is_Known_Non_Null (Ent, False); end if; + -- Follow renaming chain + if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant) and then Present (Renamed_Object (Ent)) then @@ -6746,6 +6841,18 @@ package body Sem_Util is end if; Btyp := Root_Type (Btyp); + + -- The accessibility level of anonymous acccess types associated with + -- discriminants is that of the current instance of the type, and + -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). + + if Ekind (Typ) = E_Anonymous_Access_Type + and then Present (Associated_Node_For_Itype (Typ)) + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Discriminant_Specification + then + return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)) + 1; + end if; end if; return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b7844a06f0f..c6f847b11ae 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -136,11 +136,12 @@ package Sem_Util is Ent : Entity_Id := Empty; Loc : Source_Ptr := No_Location; Warn : Boolean := False) return Node_Id; - -- Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines. - -- Does not modify any nodes, but generates a warning (or error) message. - -- For convenience, the function always returns its first argument. The - -- message is a warning if the message ends with ?, or we are operating - -- in Ada 83 mode, or if the Warn parameter is set to True. + -- This is similar to Apply_Compile_Time_Constraint_Error in that it + -- generates a warning (or error) message in the same manner, but it does + -- not replace any nodes. For convenience, the function always returns its + -- first argument. The message is a warning if the message ends with ?, or + -- we are operating in Ada 83 mode, or if the Warn parameter is set to + -- True. procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id); -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag @@ -194,10 +195,15 @@ package Sem_Util is -- an expanded name, a defining program unit name or an identifier function Enclosing_Generic_Body - (E : Entity_Id) return Node_Id; + (N : Node_Id) return Node_Id; -- Returns the Node_Id associated with the innermost enclosing -- generic body, if any. If none, then returns Empty. + function Enclosing_Generic_Unit + (N : Node_Id) return Node_Id; + -- Returns the Node_Id associated with the innermost enclosing + -- generic unit, if any. If none, then returns Empty. + function Enclosing_Lib_Unit_Entity return Entity_Id; -- Returns the entity of enclosing N_Compilation_Unit Node which is the -- root of the current scope (which must not be Standard_Standard, and @@ -216,7 +222,7 @@ package Sem_Util is -- build and initialize a new freeze node and set Has_Delayed_Freeze -- true for entity E. - procedure Enter_Name (Def_Id : Node_Id); + procedure Enter_Name (Def_Id : Entity_Id); -- Insert new name in symbol table of current scope with check for -- duplications (error message is issued if a conflict is found) -- Note: Enter_Name is not used for overloadable entities, instead @@ -627,6 +633,11 @@ package Sem_Util is -- Is_Known_Non_Null flags in variables, constants or parameters -- since these are also not known to be valid. + procedure Kill_Current_Values (Ent : Entity_Id); + -- This performs the same processing as described above for the form with + -- no argument, but for the specific entity given. The call has no effect + -- if the entity Ent is not for an object. + procedure Kill_Size_Check_Code (E : Entity_Id); -- Called when an address clause or pragma Import is applied to an -- entity. If the entity is a variable or a constant, and size check -- 2.30.2