From: Ed Schonberg Date: Fri, 6 Apr 2007 09:27:31 +0000 (+0200) Subject: sem_util.ads, [...] (Object_Access_Level): If the object is a dereference of a local... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=9e87a68deb22cb321bcec7c4cb6da10aa4a81827;p=gcc.git sem_util.ads, [...] (Object_Access_Level): If the object is a dereference of a local object R created as a reference to... 2007-04-06 Ed Schonberg Javier Miranda * sem_util.ads, sem_util.adb (Object_Access_Level): If the object is a dereference of a local object R created as a reference to another object O, use the access level of O. (Matches_Prefixed_View_Profile): Use common predicate Conforming_Types, rather than local Same_Formal_Type, to check whether protected operation overrides an inherited one. (Same_Formal_Type): New predicate, used when matching signatures of overriding synchronized operations, to handle the case when a formal has a type that is a generic actual. (Is_Aliased_View): Replace check on E_Task_Type and E_Protected_Type by predicate Is_Concurrent_Type. This ensures supportin case of subtypes. (Needs_One_Actual): New predicate, for Ada 2005 use, to resolve syntactic ambiguities involving indexing of function calls that return arrays. (Abstract_Interface_List): New subprogram that returns the list of abstract interfaces associated with a concurrent type or a concurrent record type. (Interface_Present_In_Parent): New subprogram used to check if a given type or some of its parents implement a given interface. (Collect_Abstract_Interfaces): Add support for concurrent types with interface types. (Has_Abstract_Interfaces): Add support for concurrent types with interface types. (Is_Parent): New subprogram that determines whether E1 is a parent of E2. For a concurrent type its parent is the first element of its list of interface types; for other types this function provides the same result than Is_Ancestor. (Enclosing_Subprogram): Add test for N_Extended_Return_Statement. (Collect_Synchronized_Interfaces): Removed because the subprogram Collect_Abstract_Interfaces provides this functionality. (Collect_Abstract_Interfaces): Minor update to give support to concurrent types and thus avoid undesired code duplication. (Get_Subprogram_Entity): Handle entry calls. (May_Be_Lvalue): Include actuals that appear as in-out parameters in entry calls. (Enter_Name): Do not give -gnatwh hiding warning for record component entities, they never result in hiding. From-SVN: r123599 --- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 96378f66961..f623f16fc6b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind; with Scans; use Scans; with Scn; use Scn; with Sem; use Sem; +with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -84,6 +85,58 @@ package body Sem_Util is -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. + ------------------------------ + -- Abstract_Interface_List -- + ------------------------------ + + function Abstract_Interface_List (Typ : Entity_Id) return List_Id is + Nod : Node_Id; + + begin + if Is_Concurrent_Type (Typ) then + Nod := Parent (Typ); + + elsif Ekind (Typ) = E_Record_Type_With_Private then + if Nkind (Parent (Typ)) = N_Full_Type_Declaration then + Nod := Type_Definition (Parent (Typ)); + + elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then + if Present (Full_View (Typ)) then + Nod := Type_Definition (Parent (Full_View (Typ))); + + -- If the full-view is not available we cannot do anything + -- else here (the source has errors) + + else + return Empty_List; + end if; + + -- The support for generic formals with interfaces is still + -- missing??? + + elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then + return Empty_List; + + else + pragma Assert + (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); + Nod := Parent (Typ); + end if; + + elsif Ekind (Typ) = E_Record_Subtype then + Nod := Type_Definition (Parent (Etype (Typ))); + + else pragma Assert ((Ekind (Typ)) = E_Record_Type); + if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then + Nod := Formal_Type_Definition (Parent (Typ)); + else + Nod := Type_Definition (Parent (Typ)); + end if; + end if; + + return Interface_List (Nod); + end Abstract_Interface_List; + -------------------------------- -- Add_Access_Type_To_Process -- -------------------------------- @@ -971,6 +1024,13 @@ package body Sem_Util is -- Subsidiary subprogram used to traverse the whole list -- of directly and indirectly implemented interfaces + function Interface_Present_In_Parent + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean; + -- Typ must be a tagged record type/subtype and Iface must be an + -- abstract interface type. This function is used to check if Typ + -- or some parent of Typ implements Iface. + ------------------- -- Add_Interface -- ------------------- @@ -994,54 +1054,31 @@ package body Sem_Util is ------------- procedure Collect (Typ : Entity_Id) is - Ancestor : Entity_Id; - Id : Node_Id; - Iface : Entity_Id; - Nod : Node_Id; + Iface_List : constant List_Id := Abstract_Interface_List (Typ); + Ancestor : Entity_Id; + Id : Node_Id; + Iface : Entity_Id; begin - if Ekind (Typ) = E_Record_Type_With_Private then - if Nkind (Parent (Typ)) = N_Full_Type_Declaration then - Nod := Type_Definition (Parent (Typ)); + -- Include the ancestor if we are generating the whole list of + -- abstract interfaces. - elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then - if Present (Full_View (Typ)) then - Nod := Type_Definition (Parent (Full_View (Typ))); + -- In concurrent types the ancestor interface (if any) is the + -- first element of the list of interface types. - -- If the full-view is not available we cannot do anything - -- else here (the source has errors) + if Is_Concurrent_Type (Typ) + or else Is_Concurrent_Record_Type (Typ) + then + if Is_Non_Empty_List (Iface_List) then + Ancestor := Etype (First (Iface_List)); + Collect (Ancestor); - else - return; + if not Exclude_Parent_Interfaces then + Add_Interface (Ancestor); end if; - - -- The support for generic formals with interfaces is still - -- missing??? - - elsif Nkind (Parent (Typ)) = N_Formal_Type_Declaration then - return; - - else - pragma Assert - (Nkind (Parent (Typ)) = N_Private_Extension_Declaration); - Nod := Parent (Typ); end if; - elsif Ekind (Typ) = E_Record_Subtype then - Nod := Type_Definition (Parent (Etype (Typ))); - - else pragma Assert ((Ekind (Typ)) = E_Record_Type); - if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then - Nod := Formal_Type_Definition (Parent (Typ)); - else - Nod := Type_Definition (Parent (Typ)); - end if; - end if; - - -- Include the ancestor if we are generating the whole list of - -- abstract interfaces. - - if Etype (Typ) /= Typ + elsif Etype (Typ) /= Typ -- Protect the frontend against wrong sources. For example: @@ -1068,8 +1105,19 @@ package body Sem_Util is -- Traverse the graph of ancestor interfaces - if Is_Non_Empty_List (Interface_List (Nod)) then - Id := First (Interface_List (Nod)); + if Is_Non_Empty_List (Iface_List) then + Id := First (Iface_List); + + -- In concurrent types the ancestor interface (if any) is the + -- first element of the list of interface types and we have + -- already processed them while climbing to the root type. + + if Is_Concurrent_Type (Typ) + or else Is_Concurrent_Record_Type (Typ) + then + Next (Id); + end if; + while Present (Id) loop Iface := Etype (Id); @@ -1080,7 +1128,7 @@ package body Sem_Util is if Is_Interface (Iface) then if Exclude_Parent_Interfaces - and then Interface_Present_In_Ancestor (T, Iface) + and then Interface_Present_In_Parent (T, Iface) then null; else @@ -1094,10 +1142,37 @@ package body Sem_Util is end if; end Collect; + --------------------------------- + -- Interface_Present_In_Parent -- + --------------------------------- + + function Interface_Present_In_Parent + (Typ : Entity_Id; + Iface : Entity_Id) return Boolean + is + Aux : Entity_Id := Typ; + Iface_List : List_Id; + + begin + if Is_Concurrent_Type (Typ) + or else Is_Concurrent_Record_Type (Typ) + then + Iface_List := Abstract_Interface_List (Typ); + + if Is_Non_Empty_List (Iface_List) then + Aux := Etype (First (Iface_List)); + else + return False; + end if; + end if; + + return Interface_Present_In_Ancestor (Aux, Iface); + end Interface_Present_In_Parent; + -- Start of processing for Collect_Abstract_Interfaces begin - pragma Assert (Is_Tagged_Type (T)); + pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); end Collect_Abstract_Interfaces; @@ -1236,92 +1311,6 @@ package body Sem_Util is return Op_List; end Collect_Primitive_Operations; - ------------------------------------- - -- Collect_Synchronized_Interfaces -- - ------------------------------------- - - procedure Collect_Synchronized_Interfaces - (Typ : Entity_Id; - Ifaces_List : out Elist_Id) - is - Iface : Entity_Id; - - procedure Collect (Typ : Entity_Id); - -- Gather any parent or progenitor interfaces of type Typ - - ------------- - -- Collect -- - ------------- - - procedure Collect (Typ : Entity_Id) is - Iface_Elmt : Elmt_Id; - - procedure Add (Iface : Entity_Id); - -- Add a single interface to list Ifaces if the interface is - -- not already in the list. - - --------- - -- Add -- - --------- - - procedure Add (Iface : Entity_Id) is - Iface_Elmt : Elmt_Id; - - begin - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) - and then Node (Iface_Elmt) /= Iface - loop - Next_Elmt (Iface_Elmt); - end loop; - - if No (Iface_Elmt) then - Append_Elmt (Iface, Ifaces_List); - end if; - end Add; - - -- Start of processing for Collect - - begin - if Is_Interface (Typ) then - - -- Potential parent interface - - if Etype (Typ) /= Typ then - Collect (Etype (Typ)); - end if; - - -- Progenitors - - if Present (Abstract_Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (Iface_Elmt) loop - Collect (Node (Iface_Elmt)); - Next_Elmt (Iface_Elmt); - end loop; - end if; - - Add (Typ); - end if; - end Collect; - - -- Start of processing for Collect_Synchronized_Interfaces - - begin - pragma Assert (Is_Concurrent_Type (Typ)); - - Ifaces_List := New_Elmt_List; - - if Present (Interface_List (Parent (Typ))) then - Iface := First (Interface_List (Parent (Typ))); - while Present (Iface) loop - Collect (Etype (Iface)); - - Next (Iface); - end loop; - end if; - end Collect_Synchronized_Interfaces; - ----------------------------------- -- Compile_Time_Constraint_Error -- ----------------------------------- @@ -1945,7 +1934,9 @@ package body Sem_Util is elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then return Corresponding_Spec (Parent (Parent (Dynamic_Scope))); - elsif Ekind (Dynamic_Scope) = E_Block then + elsif Ekind (Dynamic_Scope) = E_Block + or else Ekind (Dynamic_Scope) = E_Return_Statement + then return Enclosing_Subprogram (Dynamic_Scope); elsif Ekind (Dynamic_Scope) = E_Task_Type then @@ -2286,6 +2277,17 @@ package body Sem_Util is if Warn_On_Hiding and then Present (C) + -- Don't warn for record components since they always have a well + -- defined scope which does not confuse other uses. Note that in + -- some cases, Ekind has not been set yet. + + and then Ekind (C) /= E_Component + and then Ekind (C) /= E_Discriminant + and then Nkind (Parent (C)) /= N_Component_Declaration + and then Ekind (Def_Id) /= E_Component + and then Ekind (Def_Id) /= E_Discriminant + and then Nkind (Parent (Def_Id)) /= N_Component_Declaration + -- Don't warn for one character variables. It is too common to use -- such variables as locals and will just cause too many false hits. @@ -3062,6 +3064,17 @@ package body Sem_Util is begin if Nkind (Nod) = N_Accept_Statement then Nam := Entry_Direct_Name (Nod); + + -- For an entry call, the prefix of the call is a selected component. + -- Need additional code for internal calls ??? + + elsif Nkind (Nod) = N_Entry_Call_Statement then + if Nkind (Name (Nod)) = N_Selected_Component then + Nam := Entity (Selector_Name (Name (Nod))); + else + Nam := Empty; + end if; + else Nam := Name (Nod); end if; @@ -3167,6 +3180,14 @@ package body Sem_Util is pragma Assert (Is_Record_Type (Tagged_Type) and then Is_Tagged_Type (Tagged_Type)); + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Tagged_Type) + and then Is_Non_Empty_List (Abstract_Interface_List (Tagged_Type)) + then + return True; + end if; + -- Handle private types if Present (Full_View (Tagged_Type)) then @@ -3236,17 +3257,13 @@ package body Sem_Util is Comp : Entity_Id; begin - Comp := First_Entity (Typ); + Comp := First_Component_Or_Discriminant (Typ); while Present (Comp) loop - if (Ekind (Comp) = E_Component - or else - Ekind (Comp) = E_Discriminant) - and then Has_Access_Values (Etype (Comp)) - then + if Has_Access_Values (Etype (Comp)) then return True; end if; - Next_Entity (Comp); + Next_Component_Or_Discriminant (Comp); end loop; end; @@ -3776,8 +3793,8 @@ package body Sem_Util is -- We are interested only in components and discriminants if Ekind (Ent) = E_Component - or else - Ekind (Ent) = E_Discriminant + or else + Ekind (Ent) = E_Discriminant then -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and @@ -4382,9 +4399,8 @@ package body Sem_Util is or else Ekind (E) = E_Generic_In_Parameter) and then Is_Tagged_Type (Etype (E))) - or else ((Ekind (E) = E_Task_Type - or else Ekind (E) = E_Protected_Type) - and then In_Open_Scopes (E)) + or else (Is_Concurrent_Type (E) + and then In_Open_Scopes (E)) -- Current instance of type, either directly or as rewritten -- reference to the current object. @@ -4394,6 +4410,7 @@ package body Sem_Util is and then Is_Type (Entity (Original_Node (Obj)))) or else (Is_Type (E) and then E = Current_Scope) + or else (Is_Incomplete_Or_Private_Type (E) and then Full_View (E) = Current_Scope); @@ -5259,6 +5276,33 @@ package body Sem_Util is end if; end Is_OK_Variable_For_Out_Formal; + --------------- + -- Is_Parent -- + --------------- + + function Is_Parent + (E1 : Entity_Id; + E2 : Entity_Id) return Boolean + is + Iface_List : List_Id; + T : Entity_Id := E2; + + begin + if Is_Concurrent_Type (T) + or else Is_Concurrent_Record_Type (T) + then + Iface_List := Abstract_Interface_List (E2); + + if Is_Empty_List (Iface_List) then + return False; + end if; + + T := Etype (First (Iface_List)); + end if; + + return Is_Ancestor (E1, T); + end Is_Parent; + ----------------------------------- -- Is_Partially_Initialized_Type -- ----------------------------------- @@ -6241,9 +6285,10 @@ package body Sem_Util is when N_Function_Call => return False; - -- Positional parameter for procedure or accept call + -- Positional parameter for procedure, entry, or accept call when N_Procedure_Call_Statement | + N_Entry_Call_Statement | N_Accept_Statement => declare @@ -6340,6 +6385,33 @@ package body Sem_Util is end case; end May_Be_Lvalue; + ---------------------- + -- Needs_One_Actual -- + ---------------------- + + function Needs_One_Actual (E : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + if Ada_Version >= Ada_05 + and then Present (First_Formal (E)) + then + Formal := Next_Formal (First_Formal (E)); + while Present (Formal) loop + if No (Default_Value (Formal)) then + return False; + end if; + + Next_Formal (Formal); + end loop; + + return True; + + else + return False; + end if; + end Needs_One_Actual; + ------------------------- -- New_External_Entity -- ------------------------- @@ -6853,6 +6925,34 @@ package body Sem_Util is -- is not always one is immaterial (invariant: if level(E2) is -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). + function Reference_To (Obj : Node_Id) return Node_Id; + -- An explicit dereference is created when removing side-effects + -- from expressions for constraint checking purposes. In this case + -- a local access type is created for it. The correct access level + -- is that of the original source node. We detect this case by + -- noting that the prefix of the dereference is created by an object + -- declaration whose initial expression is a reference. + + ------------------ + -- Reference_To -- + ------------------ + + function Reference_To (Obj : Node_Id) return Node_Id is + Pref : constant Node_Id := Prefix (Obj); + begin + if Is_Entity_Name (Pref) + and then Nkind (Parent (Entity (Pref))) = N_Object_Declaration + and then Present (Expression (Parent (Entity (Pref)))) + and then Nkind (Expression (Parent (Entity (Pref)))) = N_Reference + then + return (Prefix (Expression (Parent (Entity (Pref))))); + else + return Empty; + end if; + end Reference_To; + + -- Start of processing for Object_Access_Level + begin if Is_Entity_Name (Obj) then E := Entity (Obj); @@ -6912,6 +7012,18 @@ package body Sem_Util is Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant then return Object_Access_Level (Prefix (Obj)); + + elsif not (Comes_From_Source (Obj)) then + declare + Ref : constant Node_Id := Reference_To (Obj); + begin + if Present (Ref) then + return Object_Access_Level (Ref); + else + return Type_Access_Level (Etype (Prefix (Obj))); + end if; + end; + else return Type_Access_Level (Etype (Prefix (Obj))); end if; @@ -7044,8 +7156,10 @@ package body Sem_Util is if Ekind (Defining_Identifier (Subp_Param)) /= Ekind (Defining_Identifier (Over_Param)) or else - Etype (Parameter_Type (Subp_Param)) /= - Etype (Parameter_Type (Over_Param)) + not Conforming_Types + (Etype (Parameter_Type (Subp_Param)), + Etype (Parameter_Type (Over_Param)), + Subtype_Conformant) then return False; end if; @@ -7083,7 +7197,7 @@ package body Sem_Util is if Ekind (Def_Id) = E_Entry and then Ekind (Candidate) = E_Procedure and then Nkind (Parent (Candidate)) = N_Procedure_Specification - and then (Is_Abstract (Candidate) + and then (Is_Abstract_Subprogram (Candidate) or else Null_Present (Parent (Candidate))) then while Present (Alias (Candidate)) loop @@ -7102,7 +7216,7 @@ package body Sem_Util is elsif Ekind (Def_Id) = E_Procedure and then Ekind (Candidate) = E_Procedure and then Nkind (Parent (Candidate)) = N_Procedure_Specification - and then (Is_Abstract (Candidate) + and then (Is_Abstract_Subprogram (Candidate) or else Null_Present (Parent (Candidate))) and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), @@ -7115,7 +7229,7 @@ package body Sem_Util is elsif Ekind (Def_Id) = E_Function and then Ekind (Candidate) = E_Function and then Nkind (Parent (Candidate)) = N_Function_Specification - and then Is_Abstract (Candidate) + and then Is_Abstract_Subprogram (Candidate) and then Matches_Prefixed_View_Profile (Parameter_Specifications (Parent (Def_Id)), Parameter_Specifications (Parent (Candidate))) @@ -7995,6 +8109,7 @@ package body Sem_Util is then Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2)); end if; + Set_Alignment (T1, Alignment (T2)); end Set_Size_Info; @@ -8461,9 +8576,9 @@ package body Sem_Util is else if From_With_Type (Found_Type) then Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); - Error_Msg_NE - ("\possibly missing with_clause on&", Expr, - Scope (Found_Type)); + Error_Msg_Qual_Level := 99; + Error_Msg_NE ("\\missing `WITH &;", Expr, Scope (Found_Type)); + Error_Msg_Qual_Level := 0; else Error_Msg_NE ("found}!", Expr, Found_Type); end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ad2404b372e..8b6ee893107 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -33,6 +33,10 @@ with Urealp; use Urealp; package Sem_Util is + function Abstract_Interface_List (Typ : Entity_Id) return List_Id; + -- Given a type that implements interfaces look for its associated + -- definition node and return its list of interfaces. + procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id); -- Add A to the list of access types to process when expanding the -- freeze node of E. @@ -140,12 +144,6 @@ package Sem_Util is -- one subsidiary subtype of the type. These subprograms can only -- appear after the type itself. - procedure Collect_Synchronized_Interfaces - (Typ : Entity_Id; - Ifaces_List : out Elist_Id); - -- Similar to Collect_Abstract_Interfaces, but tailored to task and - -- protected types. - function Compile_Time_Constraint_Error (N : Node_Id; Msg : String; @@ -598,12 +596,20 @@ package Sem_Util is -- is a variable (in the Is_Variable sense) with a non-tagged type -- target are considered view conversions and hence variables. + function Is_Parent + (E1 : Entity_Id; + E2 : Entity_Id) return Boolean; + -- Determine whether E1 is a parent of E2. For a concurrent type, the + -- parent is the first element of its list of interface types; for other + -- types, this function provides the same result as Is_Ancestor. + function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean; -- Typ is a type entity. This function returns true if this type is -- partly initialized, meaning that an object of the type is at least -- partly initialized (in particular in the record case, that at least - -- one field has an initialization expression). Note that initialization - -- resulting from the use of pragma Normalized_Scalars does not count. + -- one component has an initialization expression). Note that + -- initialization resulting from the use of pragma Normalized_Scalars does + -- not count. function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially @@ -618,7 +624,7 @@ package Sem_Util is -- body of a remote call interface package. function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean; - -- Return True if E is a remote access-to-class-wide-limited_private type + -- Return True if E is a remote access-to-class-wide type function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean; -- Return True if E is a remote access to subprogram type @@ -710,6 +716,11 @@ package Sem_Util is -- to guarantee this in all cases. Note that it is more possible to give -- correct answer if the tree is fully analyzed. + function Needs_One_Actual (E : Entity_Id) return Boolean; + -- Returns True if a function has defaults for all but its first + -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that + -- results from an indexing of a function call written in prefix form. + function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id;