X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_util.adb;h=82dca5662a30dd4d25856a628d5169b577718301;hb=169337519eece470dd1e178a4356030a6c845b37;hp=600a7bf88188bb0c4dd7acef9e457e1989ca48be;hpb=b2a25df571038094efdd4d847090275122398f0e;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 600a7bf8818..82dca5662a3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2008, 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- -- @@ -29,6 +29,7 @@ with Checks; use Checks; with Debug; use Debug; with Errout; use Errout; with Elists; use Elists; +with Exp_Disp; use Exp_Disp; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -43,14 +44,12 @@ with Scans; use Scans; with Scn; use Scn; with Sem; use Sem; with Sem_Attr; use Sem_Attr; -with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sinfo; use Sinfo; with Sinput; use Sinput; -with Snames; use Snames; with Stand; use Stand; with Style; with Stringt; use Stringt; @@ -61,8 +60,6 @@ with Uname; use Uname; package body Sem_Util is - use Nmake; - ----------------------- -- Local Subprograms -- ----------------------- @@ -102,6 +99,10 @@ package body Sem_Util is Nod := Parent (Base_Type (Typ)); + if Nkind (Nod) = N_Full_Type_Declaration then + return Empty_List; + end if; + elsif Ekind (Typ) = E_Record_Type_With_Private then if Nkind (Parent (Typ)) = N_Full_Type_Declaration then Nod := Type_Definition (Parent (Typ)); @@ -133,9 +134,11 @@ package body Sem_Util is elsif Ekind (Typ) = E_Record_Subtype_With_Private then - -- Recurse, because parent may still be a private extension + -- Recurse, because parent may still be a private extension. Also + -- note that the full view of the subtype or the full view of its + -- base type may (both) be unavailable. - return Abstract_Interface_List (Etype (Full_View (Typ))); + return Abstract_Interface_List (Etype (Typ)); else pragma Assert ((Ekind (Typ)) = E_Record_Type); if Nkind (Parent (Typ)) = N_Formal_Type_Declaration then @@ -206,8 +209,10 @@ package body Sem_Util is Rep : Boolean := True; Warn : Boolean := False) is - Stat : constant Boolean := Is_Static_Expression (N); - Rtyp : Entity_Id; + Stat : constant Boolean := Is_Static_Expression (N); + R_Stat : constant Node_Id := + Make_Raise_Constraint_Error (Sloc (N), Reason => Reason); + Rtyp : Entity_Id; begin if No (Typ) then @@ -226,10 +231,9 @@ package body Sem_Util is -- Now we replace the node by an N_Raise_Constraint_Error node -- This does not need reanalyzing, so set it as analyzed now. - Rewrite (N, - Make_Raise_Constraint_Error (Sloc (N), - Reason => Reason)); + Rewrite (N, R_Stat); Set_Analyzed (N, True); + Set_Etype (N, Rtyp); Set_Raises_Constraint_Error (N); @@ -327,11 +331,19 @@ package body Sem_Util is else Constraints := New_List; - if Is_Private_Type (T) and then No (Full_View (T)) then + -- Type T is a generic derived type, inherit the discriminants from + -- the parent type. - -- Type is a generic derived type. Inherit discriminants from - -- Parent type. + if Is_Private_Type (T) + and then No (Full_View (T)) + -- T was flagged as an error if it was declared as a formal + -- derived type with known discriminants. In this case there + -- is no need to look at the parent type since T already carries + -- its own discriminants. + + and then not Error_Posted (T) + then Disc_Type := Etype (Base_Type (T)); else Disc_Type := T; @@ -479,9 +491,13 @@ package body Sem_Util is -- Start of processing for Build_Actual_Subtype_Of_Component begin - if In_Default_Expression then + -- Why the test for Spec_Expression mode here??? + + if In_Spec_Expression then return Empty; + -- More comments for the rest of this body would be good ??? + elsif Nkind (N) = N_Explicit_Dereference then if Is_Composite_Type (T) and then not Is_Constrained (T) @@ -516,13 +532,14 @@ package body Sem_Util is while Present (Id) loop Indx_Type := Underlying_Type (Etype (Id)); - if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) or else + if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) + or else Denotes_Discriminant (Type_High_Bound (Indx_Type)) then Remove_Side_Effects (P); return - Build_Component_Subtype ( - Build_Actual_Array_Constraint, Loc, Base_Type (T)); + Build_Component_Subtype + (Build_Actual_Array_Constraint, Loc, Base_Type (T)); end if; Next_Index (Id); @@ -1002,11 +1019,12 @@ package body Sem_Util is ("premature usage of incomplete}", N, First_Subtype (T)); end if; + -- Need comments for these tests ??? + elsif Has_Private_Component (T) and then not Is_Generic_Type (Root_Type (T)) - and then not In_Default_Expression + and then not In_Spec_Expression then - -- Special case: if T is the anonymous type created for a single -- task or protected object, use the name of the source object. @@ -1031,11 +1049,14 @@ package body Sem_Util is procedure Check_Nested_Access (Ent : Entity_Id) is Scop : constant Entity_Id := Current_Scope; Current_Subp : Entity_Id; + Enclosing : Entity_Id; begin -- Currently only enabled for VM back-ends for efficiency, should we -- enable it more systematically ??? + -- Check for Is_Imported needs commenting below ??? + if VM_Target /= No_VM and then (Ekind (Ent) = E_Variable or else @@ -1044,6 +1065,7 @@ package body Sem_Util is Ekind (Ent) = E_Loop_Parameter) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) + and then not Is_Imported (Ent) then if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) @@ -1054,7 +1076,11 @@ package body Sem_Util is Current_Subp := Current_Subprogram; end if; - if Enclosing_Subprogram (Ent) /= Current_Subp then + Enclosing := Enclosing_Subprogram (Ent); + + if Enclosing /= Empty + and then Enclosing /= Current_Subp + then Set_Has_Up_Level_Access (Ent, True); end if; end if; @@ -1090,6 +1116,117 @@ package body Sem_Util is end loop; end Check_Potentially_Blocking_Operation; + ------------------------------ + -- Check_Unprotected_Access -- + ------------------------------ + + procedure Check_Unprotected_Access + (Context : Node_Id; + Expr : Node_Id) + is + Cont_Encl_Typ : Entity_Id; + Pref_Encl_Typ : Entity_Id; + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id; + -- Check whether Obj is a private component of a protected object. + -- Return the protected type where the component resides, Empty + -- otherwise. + + function Is_Public_Operation return Boolean; + -- Verify that the enclosing operation is callable from outside the + -- protected object, to minimize false positives. + + ------------------------------ + -- Enclosing_Protected_Type -- + ------------------------------ + + function Enclosing_Protected_Type (Obj : Node_Id) return Entity_Id is + begin + if Is_Entity_Name (Obj) then + declare + Ent : Entity_Id := Entity (Obj); + + begin + -- The object can be a renaming of a private component, use + -- the original record component. + + if Is_Prival (Ent) then + Ent := Prival_Link (Ent); + end if; + + if Is_Protected_Type (Scope (Ent)) then + return Scope (Ent); + end if; + end; + end if; + + -- For indexed and selected components, recursively check the prefix + + if Nkind_In (Obj, N_Indexed_Component, N_Selected_Component) then + return Enclosing_Protected_Type (Prefix (Obj)); + + -- The object does not denote a protected component + + else + return Empty; + end if; + end Enclosing_Protected_Type; + + ------------------------- + -- Is_Public_Operation -- + ------------------------- + + function Is_Public_Operation return Boolean is + S : Entity_Id; + E : Entity_Id; + + begin + S := Current_Scope; + while Present (S) + and then S /= Pref_Encl_Typ + loop + if Scope (S) = Pref_Encl_Typ then + E := First_Entity (Pref_Encl_Typ); + while Present (E) + and then E /= First_Private_Entity (Pref_Encl_Typ) + loop + if E = S then + return True; + end if; + Next_Entity (E); + end loop; + end if; + + S := Scope (S); + end loop; + + return False; + end Is_Public_Operation; + + -- Start of processing for Check_Unprotected_Access + + begin + if Nkind (Expr) = N_Attribute_Reference + and then Attribute_Name (Expr) = Name_Unchecked_Access + then + Cont_Encl_Typ := Enclosing_Protected_Type (Context); + Pref_Encl_Typ := Enclosing_Protected_Type (Prefix (Expr)); + + -- Check whether we are trying to export a protected component to a + -- context with an equal or lower access level. + + if Present (Pref_Encl_Typ) + and then No (Cont_Encl_Typ) + and then Is_Public_Operation + and then Scope_Depth (Pref_Encl_Typ) >= + Object_Access_Level (Context) + then + Error_Msg_N + ("?possible unprotected access to protected data", Expr); + end if; + end if; + end Check_Unprotected_Access; + --------------- -- Check_VMS -- --------------- @@ -1102,48 +1239,20 @@ package body Sem_Util is end if; end Check_VMS; - --------------------------------- - -- Collect_Abstract_Interfaces -- - --------------------------------- + ------------------------ + -- Collect_Interfaces -- + ------------------------ - procedure Collect_Abstract_Interfaces - (T : Entity_Id; - Ifaces_List : out Elist_Id; - Exclude_Parent_Interfaces : Boolean := False; - Use_Full_View : Boolean := True) + procedure Collect_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parents : Boolean := False; + Use_Full_View : Boolean := True) is - procedure Add_Interface (Iface : Entity_Id); - -- Add the interface it if is not already in the list - procedure Collect (Typ : Entity_Id); -- 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 -- - ------------------- - - procedure Add_Interface (Iface : Entity_Id) is - Elmt : Elmt_Id; - - begin - Elmt := First_Elmt (Ifaces_List); - while Present (Elmt) and then Node (Elmt) /= Iface loop - Next_Elmt (Elmt); - end loop; - - if No (Elmt) then - Append_Elmt (Iface, Ifaces_List); - end if; - end Add_Interface; - ------------- -- Collect -- ------------- @@ -1151,7 +1260,6 @@ package body Sem_Util is procedure Collect (Typ : Entity_Id) is Ancestor : Entity_Id; Full_T : Entity_Id; - Iface_List : List_Id; Id : Node_Id; Iface : Entity_Id; @@ -1167,27 +1275,10 @@ package body Sem_Util is Full_T := Full_View (Typ); end if; - Iface_List := Abstract_Interface_List (Full_T); - -- Include the ancestor if we are generating the whole list of -- abstract interfaces. - -- In concurrent types the ancestor interface (if any) is the - -- first element of the list of interface types. - - if Is_Concurrent_Type (Full_T) - or else Is_Concurrent_Record_Type (Full_T) - then - if Is_Non_Empty_List (Iface_List) then - Ancestor := Etype (First (Iface_List)); - Collect (Ancestor); - - if not Exclude_Parent_Interfaces then - Add_Interface (Ancestor); - end if; - end if; - - elsif Etype (Full_T) /= Typ + if Etype (Full_T) /= Typ -- Protect the frontend against wrong sources. For example: @@ -1206,27 +1297,16 @@ package body Sem_Util is Collect (Ancestor); if Is_Interface (Ancestor) - and then not Exclude_Parent_Interfaces + and then not Exclude_Parents then - Add_Interface (Ancestor); + Append_Unique_Elmt (Ancestor, Ifaces_List); end if; end if; -- Traverse the graph of ancestor interfaces - 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 (Full_T) - or else Is_Concurrent_Record_Type (Full_T) - then - Next (Id); - end if; - + if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then + Id := First (Abstract_Interface_List (Full_T)); while Present (Id) loop Iface := Etype (Id); @@ -1236,13 +1316,14 @@ package body Sem_Util is -- type Wrong is new I and O with null record; -- ERROR if Is_Interface (Iface) then - if Exclude_Parent_Interfaces - and then Interface_Present_In_Parent (T, Iface) + if Exclude_Parents + and then Etype (T) /= T + and then Interface_Present_In_Ancestor (Etype (T), Iface) then null; else - Collect (Iface); - Add_Interface (Iface); + Collect (Iface); + Append_Unique_Elmt (Iface, Ifaces_List); end if; end if; @@ -1251,40 +1332,13 @@ 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 + -- Start of processing for Collect_Interfaces begin pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T)); Ifaces_List := New_Elmt_List; Collect (T); - end Collect_Abstract_Interfaces; + end Collect_Interfaces; ---------------------------------- -- Collect_Interface_Components -- @@ -1328,7 +1382,7 @@ package body Sem_Util is Tag_Comp := Next_Tag_Component (First_Tag_Component (Typ)); while Present (Tag_Comp) loop - pragma Assert (Present (Related_Interface (Tag_Comp))); + pragma Assert (Present (Related_Type (Tag_Comp))); Append_Elmt (Tag_Comp, Components_List); Tag_Comp := Next_Tag_Component (Tag_Comp); @@ -1373,11 +1427,16 @@ package body Sem_Util is ADT : Elmt_Id; begin - ADT := Next_Elmt (First_Elmt (Access_Disp_Table (T))); + ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (T)))); while Present (ADT) and then Ekind (Node (ADT)) = E_Constant - and then Related_Interface (Node (ADT)) /= Iface + and then Related_Type (Node (ADT)) /= Iface loop + -- Skip the secondary dispatch tables of Iface + + Next_Elmt (ADT); + Next_Elmt (ADT); + Next_Elmt (ADT); Next_Elmt (ADT); end loop; @@ -1388,7 +1447,7 @@ package body Sem_Util is -- Start of processing for Collect_Interfaces_Info begin - Collect_Abstract_Interfaces (T, Ifaces_List); + Collect_Interfaces (T, Ifaces_List); Collect_Interface_Components (T, Comps_List); -- Search for the record component and tag associated with each @@ -1404,7 +1463,7 @@ package body Sem_Util is -- Associate the primary tag component and the primary dispatch table -- with all the interfaces that are parents of T - if Is_Parent (Iface, T) then + if Is_Ancestor (Iface, T) then Append_Elmt (First_Tag_Component (T), Components_List); Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List); @@ -1414,10 +1473,10 @@ package body Sem_Util is else Comp_Elmt := First_Elmt (Comps_List); while Present (Comp_Elmt) loop - Comp_Iface := Related_Interface (Node (Comp_Elmt)); + Comp_Iface := Related_Type (Node (Comp_Elmt)); if Comp_Iface = Iface - or else Is_Parent (Iface, Comp_Iface) + or else Is_Ancestor (Iface, Comp_Iface) then Append_Elmt (Node (Comp_Elmt), Components_List); Append_Elmt (Search_Tag (Comp_Iface), Tags_List); @@ -1754,6 +1813,42 @@ package body Sem_Util is end if; end Conditional_Delay; + ------------------------- + -- Copy_Parameter_List -- + ------------------------- + + function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id is + Loc : constant Source_Ptr := Sloc (Subp_Id); + Plist : List_Id; + Formal : Entity_Id; + + begin + if No (First_Formal (Subp_Id)) then + return No_List; + else + Plist := New_List; + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + Append + (Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Parameter_Type => + New_Reference_To (Etype (Formal), Loc), + Expression => + New_Copy_Tree (Expression (Parent (Formal)))), + Plist); + + Next_Formal (Formal); + end loop; + end if; + + return Plist; + end Copy_Parameter_List; + -------------------- -- Current_Entity -- -------------------- @@ -1818,7 +1913,6 @@ package body Sem_Util is function Current_Subprogram return Entity_Id is Scop : constant Entity_Id := Current_Scope; - begin if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then return Scop; @@ -1969,6 +2063,15 @@ package body Sem_Util is end Denotes_Discriminant; + ---------------------- + -- Denotes_Variable -- + ---------------------- + + function Denotes_Variable (N : Node_Id) return Boolean is + begin + return Is_Variable (N) and then Paren_Count (N) = 0; + end Denotes_Variable; + ----------------------------- -- Depends_On_Discriminant -- ----------------------------- @@ -2241,26 +2344,6 @@ package body Sem_Util is E : constant Entity_Id := Current_Entity_In_Scope (Def_Id); S : constant Entity_Id := Current_Scope; - function Is_Private_Component_Renaming (N : Node_Id) return Boolean; - -- Recognize a renaming declaration that is introduced for private - -- components of a protected type. We treat these as weak declarations - -- so that they are overridden by entities with the same name that - -- come from source, such as formals or local variables of a given - -- protected declaration. - - ----------------------------------- - -- Is_Private_Component_Renaming -- - ----------------------------------- - - function Is_Private_Component_Renaming (N : Node_Id) return Boolean is - begin - return not Comes_From_Source (N) - and then not Comes_From_Source (Current_Scope) - and then Nkind (N) = N_Object_Renaming_Declaration; - end Is_Private_Component_Renaming; - - -- Start of processing for Enter_Name - begin Generate_Definition (Def_Id); @@ -2384,7 +2467,29 @@ package body Sem_Util is then return; - elsif Is_Private_Component_Renaming (Parent (Def_Id)) then + -- If the homograph is a protected component renaming, it should not + -- be hiding the current entity. Such renamings are treated as weak + -- declarations. + + elsif Is_Prival (E) then + Set_Is_Immediately_Visible (E, False); + + -- In this case the current entity is a protected component renaming. + -- Perform minimal decoration by setting the scope and return since + -- the prival should not be hiding other visible entities. + + elsif Is_Prival (Def_Id) then + Set_Scope (Def_Id, Current_Scope); + return; + + -- Analogous to privals, the discriminal generated for an entry + -- index parameter acts as a weak declaration. Perform minimal + -- decoration to avoid bogus errors. + + elsif Is_Discriminal (Def_Id) + and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter + then + Set_Scope (Def_Id, Current_Scope); return; -- In the body or private part of an instance, a type extension @@ -2393,7 +2498,7 @@ package body Sem_Util is -- of the full type with two components of the same name are not -- clear at this point ??? - elsif In_Instance_Not_Visible then + elsif In_Instance_Not_Visible then null; -- When compiling a package body, some child units may have become @@ -2428,21 +2533,19 @@ package body Sem_Util is and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration then Error_Msg_N - ("incomplete type cannot be completed" & - " with a private declaration", - Parent (Def_Id)); + ("incomplete type cannot be completed with a private " & + "declaration", Parent (Def_Id)); Set_Is_Immediately_Visible (E, False); Set_Full_View (E, Def_Id); + -- An inherited component of a record conflicts with a new + -- discriminant. The discriminant is inserted first in the scope, + -- but the error should be posted on it, not on the component. + elsif Ekind (E) = E_Discriminant and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then - -- An inherited component of a record conflicts with - -- a new discriminant. The discriminant is inserted first - -- in the scope, but the error should be posted on it, not - -- on the component. - Error_Msg_Sloc := Sloc (Def_Id); Error_Msg_N ("& conflicts with declaration#", E); return; @@ -2472,8 +2575,8 @@ package body Sem_Util is end if; end if; - if Nkind (Parent (Parent (Def_Id))) - = N_Generic_Subprogram_Declaration + if Nkind (Parent (Parent (Def_Id))) = + N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then @@ -2557,7 +2660,7 @@ package body Sem_Util is and then Length_Of_Name (Chars (C)) /= 1 - -- Don't warn for non-source eneities + -- Don't warn for non-source entities and then Comes_From_Source (C) and then Comes_From_Source (Def_Id) @@ -2632,17 +2735,16 @@ package body Sem_Util is end if; end Explain_Limited_Type; - ---------------------- - -- Find_Actual_Mode -- - ---------------------- + ----------------- + -- Find_Actual -- + ----------------- - procedure Find_Actual_Mode - (N : Node_Id; - Kind : out Entity_Kind; - Call : out Node_Id) + procedure Find_Actual + (N : Node_Id; + Formal : out Entity_Id; + Call : out Node_Id) is Parnt : constant Node_Id := Parent (N); - Formal : Entity_Id; Actual : Node_Id; begin @@ -2651,7 +2753,7 @@ package body Sem_Util is Nkind (Parnt) = N_Selected_Component) and then N = Prefix (Parnt) then - Find_Actual_Mode (Parnt, Kind, Call); + Find_Actual (Parnt, Formal, Call); return; elsif Nkind (Parnt) = N_Parameter_Association @@ -2663,16 +2765,19 @@ package body Sem_Util is Call := Parnt; else - Kind := E_Void; - Call := Empty; + Formal := Empty; + Call := Empty; return; end if; - -- If we have a call to a subprogram look for the parametere + -- If we have a call to a subprogram look for the parameter. Note that + -- we exclude overloaded calls, since we don't know enough to be sure + -- of giving the right answer in this case. if Is_Entity_Name (Name (Call)) and then Present (Entity (Name (Call))) and then Is_Overloadable (Entity (Name (Call))) + and then not Is_Overloaded (Name (Call)) then -- Fall here if we are definitely a parameter @@ -2680,7 +2785,6 @@ package body Sem_Util is Formal := First_Formal (Entity (Name (Call))); while Present (Formal) and then Present (Actual) loop if Actual = N then - Kind := Ekind (Formal); return; else Actual := Next_Actual (Actual); @@ -2691,9 +2795,9 @@ package body Sem_Util is -- Fall through here if we did not find matching actual - Kind := E_Void; - Call := Empty; - end Find_Actual_Mode; + Formal := Empty; + Call := Empty; + end Find_Actual; ------------------------------------- -- Find_Corresponding_Discriminant -- @@ -2800,407 +2904,110 @@ package body Sem_Util is return Empty; end Find_Overlaid_Object; - -------------------------------------------- - -- Find_Overridden_Synchronized_Primitive -- - -------------------------------------------- - - function Find_Overridden_Synchronized_Primitive - (Def_Id : Entity_Id; - First_Hom : Entity_Id; - Ifaces_List : Elist_Id; - In_Scope : Boolean) return Entity_Id - is - Candidate : Entity_Id := Empty; - Hom : Entity_Id := Empty; - Iface_Typ : Entity_Id; - Subp : Entity_Id := Empty; - Tag_Typ : Entity_Id; - - function Find_Parameter_Type (Param : Node_Id) return Entity_Id; - -- Return the type of a formal parameter as determined by its - -- specification. - - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean; - -- For an overridden subprogram Subp, check whether the mode of its - -- first parameter is correct depending on the kind of Tag_Typ. - - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean; - -- Determine whether a subprogram's parameter profile Prim_Params - -- matches that of a potentially overriden interface subprogram - -- Iface_Params. Also determine if the type of first parameter of - -- Iface_Params is an implemented interface. - - ------------------------- - -- Find_Parameter_Type -- - ------------------------- + ------------------------- + -- Find_Parameter_Type -- + ------------------------- - function Find_Parameter_Type (Param : Node_Id) return Entity_Id is - begin - pragma Assert (Nkind (Param) = N_Parameter_Specification); + function Find_Parameter_Type (Param : Node_Id) return Entity_Id is + begin + if Nkind (Param) /= N_Parameter_Specification then + return Empty; - if Nkind (Parameter_Type (Param)) = N_Access_Definition then - return Etype (Subtype_Mark (Parameter_Type (Param))); + -- For an access parameter, obtain the type from the formal entity + -- itself, because access to subprogram nodes do not carry a type. + -- Shouldn't we always use the formal entity ??? - else - return Etype (Parameter_Type (Param)); - end if; - end Find_Parameter_Type; + elsif Nkind (Parameter_Type (Param)) = N_Access_Definition then + return Etype (Defining_Identifier (Param)); - ----------------------------- - -- Has_Correct_Formal_Mode -- - ----------------------------- + else + return Etype (Parameter_Type (Param)); + end if; + end Find_Parameter_Type; - function Has_Correct_Formal_Mode (Subp : Entity_Id) return Boolean is - Param : Node_Id; + ----------------------------- + -- Find_Static_Alternative -- + ----------------------------- - begin - Param := First_Formal (Subp); - - -- In order for an entry or a protected procedure to override, the - -- first parameter of the overridden routine must be of mode "out", - -- "in out" or access-to-variable. - - if (Ekind (Subp) = E_Entry - or else Ekind (Subp) = E_Procedure) - and then Is_Protected_Type (Tag_Typ) - and then Ekind (Param) /= E_In_Out_Parameter - and then Ekind (Param) /= E_Out_Parameter - and then Nkind (Parameter_Type (Parent (Param))) /= - N_Access_Definition - then - return False; - end if; + function Find_Static_Alternative (N : Node_Id) return Node_Id is + Expr : constant Node_Id := Expression (N); + Val : constant Uint := Expr_Value (Expr); + Alt : Node_Id; + Choice : Node_Id; - -- All other cases are OK since a task entry or routine does not - -- have a restriction on the mode of the first parameter of the - -- overridden interface routine. + begin + Alt := First (Alternatives (N)); - return True; - end Has_Correct_Formal_Mode; + Search : loop + if Nkind (Alt) /= N_Pragma then + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop - ----------------------------------- - -- Matches_Prefixed_View_Profile -- - ----------------------------------- + -- Others choice, always matches - function Matches_Prefixed_View_Profile - (Prim_Params : List_Id; - Iface_Params : List_Id) return Boolean - is - Iface_Id : Entity_Id; - Iface_Param : Node_Id; - Iface_Typ : Entity_Id; - Prim_Id : Entity_Id; - Prim_Param : Node_Id; - Prim_Typ : Entity_Id; + if Nkind (Choice) = N_Others_Choice then + exit Search; - function Is_Implemented (Iface : Entity_Id) return Boolean; - -- Determine if Iface is implemented by the current task or - -- protected type. + -- Range, check if value is in the range - -------------------- - -- Is_Implemented -- - -------------------- + elsif Nkind (Choice) = N_Range then + exit Search when + Val >= Expr_Value (Low_Bound (Choice)) + and then + Val <= Expr_Value (High_Bound (Choice)); - function Is_Implemented (Iface : Entity_Id) return Boolean is - Iface_Elmt : Elmt_Id; + -- Choice is a subtype name. Note that we know it must + -- be a static subtype, since otherwise it would have + -- been diagnosed as illegal. - begin - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - if Node (Iface_Elmt) = Iface then - return True; - end if; + elsif Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + exit Search when Is_In_Range (Expr, Etype (Choice)); - Next_Elmt (Iface_Elmt); - end loop; + -- Choice is a subtype indication - return False; - end Is_Implemented; + elsif Nkind (Choice) = N_Subtype_Indication then + declare + C : constant Node_Id := Constraint (Choice); + R : constant Node_Id := Range_Expression (C); - -- Start of processing for Matches_Prefixed_View_Profile + begin + exit Search when + Val >= Expr_Value (Low_Bound (R)) + and then + Val <= Expr_Value (High_Bound (R)); + end; - begin - Iface_Param := First (Iface_Params); - Iface_Typ := Find_Parameter_Type (Iface_Param); - Prim_Param := First (Prim_Params); + -- Choice is a simple expression - -- The first parameter of the potentially overriden subprogram - -- must be an interface implemented by Prim. + else + exit Search when Val = Expr_Value (Choice); + end if; - if not Is_Interface (Iface_Typ) - or else not Is_Implemented (Iface_Typ) - then - return False; + Next (Choice); + end loop; end if; - -- The checks on the object parameters are done, move onto the rest - -- of the parameters. - - if not In_Scope then - Prim_Param := Next (Prim_Param); - end if; + Next (Alt); + pragma Assert (Present (Alt)); + end loop Search; - Iface_Param := Next (Iface_Param); - while Present (Iface_Param) and then Present (Prim_Param) loop - Iface_Id := Defining_Identifier (Iface_Param); - Iface_Typ := Find_Parameter_Type (Iface_Param); - Prim_Id := Defining_Identifier (Prim_Param); - Prim_Typ := Find_Parameter_Type (Prim_Param); + -- The above loop *must* terminate by finding a match, since + -- we know the case statement is valid, and the value of the + -- expression is known at compile time. When we fall out of + -- the loop, Alt points to the alternative that we know will + -- be selected at run time. - -- Case of multiple interface types inside a parameter profile + return Alt; + end Find_Static_Alternative; - -- (Obj_Param : in out Iface; ...; Param : Iface) + ------------------ + -- First_Actual -- + ------------------ - -- If the interface type is implemented, then the matching type - -- in the primitive should be the implementing record type. - - if Ekind (Iface_Typ) = E_Record_Type - and then Is_Interface (Iface_Typ) - and then Is_Implemented (Iface_Typ) - then - if Prim_Typ /= Tag_Typ then - return False; - end if; - - -- The two parameters must be both mode and subtype conformant - - elsif Ekind (Iface_Id) /= Ekind (Prim_Id) - or else - not Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant) - then - return False; - end if; - - Next (Iface_Param); - Next (Prim_Param); - end loop; - - -- One of the two lists contains more parameters than the other - - if Present (Iface_Param) or else Present (Prim_Param) then - return False; - end if; - - return True; - end Matches_Prefixed_View_Profile; - - -- Start of processing for Find_Overridden_Synchronized_Primitive - - begin - -- At this point the caller should have collected the interfaces - -- implemented by the synchronized type. - - pragma Assert (Present (Ifaces_List)); - - -- Find the tagged type to which subprogram Def_Id is primitive. If the - -- subprogram was declared within a protected or a task type, the type - -- is the scope itself, otherwise it is the type of the first parameter. - - if In_Scope then - Tag_Typ := Scope (Def_Id); - - elsif Present (First_Formal (Def_Id)) then - Tag_Typ := Find_Parameter_Type (Parent (First_Formal (Def_Id))); - - -- A parameterless subprogram which is declared outside a synchronized - -- type cannot act as a primitive, thus it cannot override anything. - - else - return Empty; - end if; - - -- Traverse the homonym chain, looking at a potentially overriden - -- subprogram that belongs to an implemented interface. - - Hom := First_Hom; - while Present (Hom) loop - Subp := Hom; - - -- Entries can override abstract or null interface procedures - - if Ekind (Def_Id) = E_Entry - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - then - while Present (Alias (Subp)) loop - Subp := Alias (Subp); - end loop; - - if Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - end if; - - -- Procedures can override abstract or null interface procedures - - elsif Ekind (Def_Id) = E_Procedure - and then Ekind (Subp) = E_Procedure - and then Nkind (Parent (Subp)) = N_Procedure_Specification - and then (Is_Abstract_Subprogram (Subp) - or else Null_Present (Parent (Subp))) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - then - Candidate := Subp; - - -- Absolute match - - if Has_Correct_Formal_Mode (Candidate) then - return Candidate; - end if; - - -- Functions can override abstract interface functions - - elsif Ekind (Def_Id) = E_Function - and then Ekind (Subp) = E_Function - and then Nkind (Parent (Subp)) = N_Function_Specification - and then Is_Abstract_Subprogram (Subp) - and then Matches_Prefixed_View_Profile - (Parameter_Specifications (Parent (Def_Id)), - Parameter_Specifications (Parent (Subp))) - and then Etype (Result_Definition (Parent (Def_Id))) = - Etype (Result_Definition (Parent (Subp))) - then - return Subp; - end if; - - Hom := Homonym (Hom); - end loop; - - -- After examining all candidates for overriding, we are left with - -- the best match which is a mode incompatible interface routine. - -- Do not emit an error if the Expander is active since this error - -- will be detected later on after all concurrent types are expanded - -- and all wrappers are built. This check is meant for spec-only - -- compilations. - - if Present (Candidate) - and then not Expander_Active - then - Iface_Typ := Find_Parameter_Type (Parent (First_Formal (Candidate))); - - -- Def_Id is primitive of a protected type, declared inside the type, - -- and the candidate is primitive of a limited or synchronized - -- interface. - - if In_Scope - and then Is_Protected_Type (Tag_Typ) - and then - (Is_Limited_Interface (Iface_Typ) - or else Is_Protected_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - or else Is_Task_Interface (Iface_Typ)) - then - -- Must reword this message, comma before to in -gnatj mode ??? - - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT` or " & - "access-to-variable", Tag_Typ, Candidate); - Error_Msg_N - ("\to be overridden by protected procedure or entry " & - "(RM 9.4(11.9/2))", Tag_Typ); - end if; - end if; - - return Candidate; - end Find_Overridden_Synchronized_Primitive; - - ----------------------------- - -- Find_Static_Alternative -- - ----------------------------- - - function Find_Static_Alternative (N : Node_Id) return Node_Id is - Expr : constant Node_Id := Expression (N); - Val : constant Uint := Expr_Value (Expr); - Alt : Node_Id; - Choice : Node_Id; - - begin - Alt := First (Alternatives (N)); - - Search : loop - if Nkind (Alt) /= N_Pragma then - Choice := First (Discrete_Choices (Alt)); - while Present (Choice) loop - - -- Others choice, always matches - - if Nkind (Choice) = N_Others_Choice then - exit Search; - - -- Range, check if value is in the range - - elsif Nkind (Choice) = N_Range then - exit Search when - Val >= Expr_Value (Low_Bound (Choice)) - and then - Val <= Expr_Value (High_Bound (Choice)); - - -- Choice is a subtype name. Note that we know it must - -- be a static subtype, since otherwise it would have - -- been diagnosed as illegal. - - elsif Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - exit Search when Is_In_Range (Expr, Etype (Choice)); - - -- Choice is a subtype indication - - elsif Nkind (Choice) = N_Subtype_Indication then - declare - C : constant Node_Id := Constraint (Choice); - R : constant Node_Id := Range_Expression (C); - - begin - exit Search when - Val >= Expr_Value (Low_Bound (R)) - and then - Val <= Expr_Value (High_Bound (R)); - end; - - -- Choice is a simple expression - - else - exit Search when Val = Expr_Value (Choice); - end if; - - Next (Choice); - end loop; - end if; - - Next (Alt); - pragma Assert (Present (Alt)); - end loop Search; - - -- The above loop *must* terminate by finding a match, since - -- we know the case statement is valid, and the value of the - -- expression is known at compile time. When we fall out of - -- the loop, Alt points to the alternative that we know will - -- be selected at run time. - - return Alt; - end Find_Static_Alternative; - - ------------------ - -- First_Actual -- - ------------------ - - function First_Actual (Node : Node_Id) return Node_Id is - N : Node_Id; + function First_Actual (Node : Node_Id) return Node_Id is + N : Node_Id; begin if No (Parameter_Associations (Node)) then @@ -3277,7 +3084,7 @@ package body Sem_Util is begin Res := Internal_Full_Qualified_Name (E); - Store_String_Char (Get_Char_Code (ASCII.nul)); + Store_String_Char (Get_Char_Code (ASCII.NUL)); return End_String; end Full_Qualified_Name; @@ -3525,9 +3332,9 @@ package body Sem_Util is and then not Has_Unknown_Discriminants (Utyp) and then not (Ekind (Utyp) = E_String_Literal_Subtype) then - -- Nothing to do if in default expression + -- Nothing to do if in spec expression (why not???) - if In_Default_Expression then + if In_Spec_Expression then return Typ; elsif Is_Private_Type (Typ) @@ -3645,10 +3452,7 @@ package body Sem_Util is -- literals to search. Instead, an N_Character_Literal node is created -- with the appropriate Char_Code and Chars fields. - if Root_Type (T) = Standard_Character - or else Root_Type (T) = Standard_Wide_Character - or else Root_Type (T) = Standard_Wide_Wide_Character - then + if Is_Standard_Character_Type (T) then Set_Character_Literal_Name (UI_To_CC (Pos)); return Make_Character_Literal (Loc, @@ -3756,6 +3560,15 @@ package body Sem_Util is return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; + ------------------- + -- Get_Pragma_Id -- + ------------------- + + function Get_Pragma_Id (N : Node_Id) return Pragma_Id is + begin + return Get_Pragma_Id (Pragma_Name (N)); + end Get_Pragma_Id; + --------------------------- -- Get_Referenced_Object -- --------------------------- @@ -3877,7 +3690,7 @@ package body Sem_Util is function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is begin -- Note: A task type may be the completion of a private type with - -- discriminants. when performing elaboration checks on a task + -- discriminants. When performing elaboration checks on a task -- declaration, the current view of the type may be the private one, -- and the procedure that holds the body of the task is held in its -- underlying type. @@ -3888,72 +3701,6 @@ package body Sem_Util is return Task_Body_Procedure (Underlying_Type (Root_Type (E))); end Get_Task_Body_Procedure; - ----------------------------- - -- Has_Abstract_Interfaces -- - ----------------------------- - - function Has_Abstract_Interfaces - (Tagged_Type : Entity_Id; - Use_Full_View : Boolean := True) return Boolean - is - Typ : Entity_Id; - - begin - 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; - - Typ := Tagged_Type; - - -- Handle private types - - if Use_Full_View - and then Present (Full_View (Tagged_Type)) - then - Typ := Full_View (Tagged_Type); - end if; - - loop - if Is_Interface (Typ) - or else - (Is_Record_Type (Typ) - and then Present (Abstract_Interfaces (Typ)) - and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) - then - return True; - end if; - - exit when Etype (Typ) = Typ - - -- Handle private types - - or else (Present (Full_View (Etype (Typ))) - and then Full_View (Etype (Typ)) = Typ) - - -- Protect the frontend against wrong source with cyclic - -- derivations - - or else Etype (Typ) = Tagged_Type; - - -- Climb to the ancestor type handling private types - - if Present (Full_View (Etype (Typ))) then - Typ := Full_View (Etype (Typ)); - else - Typ := Etype (Typ); - end if; - end loop; - - return False; - end Has_Abstract_Interfaces; - ----------------------- -- Has_Access_Values -- ----------------------- @@ -3982,9 +3729,17 @@ package body Sem_Util is Comp : Entity_Id; begin + -- Loop to Check components + Comp := First_Component_Or_Discriminant (Typ); while Present (Comp) loop - if Has_Access_Values (Etype (Comp)) then + + -- Check for access component, tag field does not count, even + -- though it is implemented internally using an access type. + + if Has_Access_Values (Etype (Comp)) + and then Chars (Comp) /= Name_uTag + then return True; end if; @@ -4264,7 +4019,7 @@ package body Sem_Util is Set_Result (Unknown); -- Now check size of Expr object. Any size that is not an - -- even multiple of Maxiumum_Alignment is also worrisome + -- even multiple of Maximum_Alignment is also worrisome -- since it may cause the alignment of the object to be less -- than the alignment of the type. @@ -4400,6 +4155,82 @@ package body Sem_Util is and then Includes_Infinities (Scalar_Range (E)); end Has_Infinities; + -------------------- + -- Has_Interfaces -- + -------------------- + + function Has_Interfaces + (T : Entity_Id; + Use_Full_View : Boolean := True) return Boolean + is + Typ : Entity_Id; + + begin + -- Handle concurrent types + + if Is_Concurrent_Type (T) then + Typ := Corresponding_Record_Type (T); + else + Typ := T; + end if; + + if not Present (Typ) + or else not Is_Record_Type (Typ) + or else not Is_Tagged_Type (Typ) + then + return False; + end if; + + -- Handle private types + + if Use_Full_View + and then Present (Full_View (Typ)) + then + Typ := Full_View (Typ); + end if; + + -- Handle concurrent record types + + if Is_Concurrent_Record_Type (Typ) + and then Is_Non_Empty_List (Abstract_Interface_List (Typ)) + then + return True; + end if; + + loop + if Is_Interface (Typ) + or else + (Is_Record_Type (Typ) + and then Present (Interfaces (Typ)) + and then not Is_Empty_Elmt_List (Interfaces (Typ))) + then + return True; + end if; + + exit when Etype (Typ) = Typ + + -- Handle private types + + or else (Present (Full_View (Etype (Typ))) + and then Full_View (Etype (Typ)) = Typ) + + -- Protect the frontend against wrong source with cyclic + -- derivations + + or else Etype (Typ) = T; + + -- Climb to the ancestor type handling private types + + if Present (Full_View (Etype (Typ))) then + Typ := Full_View (Etype (Typ)); + else + Typ := Etype (Typ); + end if; + end loop; + + return False; + end Has_Interfaces; + ------------------------ -- Has_Null_Exclusion -- ------------------------ @@ -4490,6 +4321,59 @@ package body Sem_Util is end if; end Has_Null_Extension; + ------------------------------- + -- Has_Overriding_Initialize -- + ------------------------------- + + function Has_Overriding_Initialize (T : Entity_Id) return Boolean is + BT : constant Entity_Id := Base_Type (T); + Comp : Entity_Id; + P : Elmt_Id; + + begin + if Is_Controlled (BT) then + + -- For derived types, check immediate ancestor, excluding + -- Controlled itself. + + if Is_Derived_Type (BT) + and then not In_Predefined_Unit (Etype (BT)) + and then Has_Overriding_Initialize (Etype (BT)) + then + return True; + + elsif Present (Primitive_Operations (BT)) then + P := First_Elmt (Primitive_Operations (BT)); + while Present (P) loop + if Chars (Node (P)) = Name_Initialize + and then Comes_From_Source (Node (P)) + then + return True; + end if; + + Next_Elmt (P); + end loop; + end if; + + return False; + + elsif Has_Controlled_Component (BT) then + Comp := First_Component (BT); + while Present (Comp) loop + if Has_Overriding_Initialize (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + + return False; + + else + return False; + end if; + end Has_Overriding_Initialize; + -------------------------------------- -- Has_Preelaborable_Initialization -- -------------------------------------- @@ -4531,13 +4415,26 @@ package body Sem_Util is elsif Nkind (N) = N_Null then return True; - elsif Nkind (N) = N_Attribute_Reference + -- Attributes are allowed in general, even if their prefix is a + -- formal type. (It seems that certain attributes known not to be + -- static might not be allowed, but there are no rules to prevent + -- them.) + + elsif Nkind (N) = N_Attribute_Reference then + return True; + + -- The name of a discriminant evaluated within its parent type is + -- defined to be preelaborable (10.2.1(8)). Note that we test for + -- names that denote discriminals as well as discriminants to + -- catch references occurring within init procs. + + elsif Is_Entity_Name (N) and then - (Attribute_Name (N) = Name_Access - or else - Attribute_Name (N) = Name_Unchecked_Access - or else - Attribute_Name (N) = Name_Unrestricted_Access) + (Ekind (Entity (N)) = E_Discriminant + or else + ((Ekind (Entity (N)) = E_Constant + or else Ekind (Entity (N)) = E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) then return True; @@ -4668,7 +4565,7 @@ package body Sem_Util is then -- Get default expression if any. If there is no declaration -- node, it means we have an internal entity. The parent and - -- tag fields are examples of such entitires. For these cases, + -- tag fields are examples of such entities. For these cases, -- we just test the type of the entity. if Present (Declaration_Node (Ent)) then @@ -4719,14 +4616,6 @@ package body Sem_Util is return Has_Preelaborable_Initialization (Base_Type (E)); end if; - -- Other private types never have preelaborable initialization - - if Is_Private_Type (E) then - return False; - end if; - - -- Here for all non-private view - -- All elementary types have preelaborable initialization if Is_Elementary_Type (E) then @@ -4746,6 +4635,13 @@ package body Sem_Util is elsif Is_Derived_Type (E) then + -- If the derived type is a private extension then it doesn't have + -- preelaborable initialization. + + if Ekind (Base_Type (E)) = E_Record_Type_With_Private then + return False; + end if; + -- First check whether ancestor type has preelaborable initialization Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E))); @@ -4761,25 +4657,17 @@ package body Sem_Util is if Has_PE and then Is_Controlled (E) - and then Present (Primitive_Operations (E)) + and then Has_Overriding_Initialize (E) then - declare - P : Elmt_Id; + Has_PE := False; + end if; - begin - P := First_Elmt (Primitive_Operations (E)); - while Present (P) loop - if Chars (Node (P)) = Name_Initialize - and then Comes_From_Source (Node (P)) - then - Has_PE := False; - exit; - end if; + -- Private types not derived from a type having preelaborable init and + -- that are not marked with pragma Preelaborable_Initialization do not + -- have preelaborable initialization. - Next_Elmt (P); - end loop; - end; - end if; + elsif Is_Private_Type (E) then + return False; -- Record type has PI if it is non private and all components have PI @@ -4952,6 +4840,56 @@ package body Sem_Util is end if; end Has_Tagged_Component; + -------------------------- + -- Implements_Interface -- + -------------------------- + + function Implements_Interface + (Typ_Ent : Entity_Id; + Iface_Ent : Entity_Id; + Exclude_Parents : Boolean := False) return Boolean + is + Ifaces_List : Elist_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Typ : Entity_Id; + + begin + if Is_Class_Wide_Type (Typ_Ent) then + Typ := Etype (Typ_Ent); + else + Typ := Typ_Ent; + end if; + + if Is_Class_Wide_Type (Iface_Ent) then + Iface := Etype (Iface_Ent); + else + Iface := Iface_Ent; + end if; + + if not Has_Interfaces (Typ) then + return False; + end if; + + Collect_Interfaces (Typ, Ifaces_List); + + Elmt := First_Elmt (Ifaces_List); + while Present (Elmt) loop + if Is_Ancestor (Node (Elmt), Typ) + and then Exclude_Parents + then + null; + + elsif Node (Elmt) = Iface then + return True; + end if; + + Next_Elmt (Elmt); + end loop; + + return False; + end Implements_Interface; + ----------------- -- In_Instance -- ----------------- @@ -5082,9 +5020,9 @@ package body Sem_Util is return False; end In_Instance_Visible_Part; - ---------------------- - -- In_Packiage_Body -- - ---------------------- + --------------------- + -- In_Package_Body -- + --------------------- function In_Package_Body return Boolean is S : Entity_Id; @@ -5106,6 +5044,26 @@ package body Sem_Util is return False; end In_Package_Body; + -------------------------------- + -- In_Parameter_Specification -- + -------------------------------- + + function In_Parameter_Specification (N : Node_Id) return Boolean is + PN : Node_Id; + + begin + PN := Parent (N); + while Present (PN) loop + if Nkind (PN) = N_Parameter_Specification then + return True; + end if; + + PN := Parent (PN); + end loop; + + return False; + end In_Parameter_Specification; + -------------------------------------- -- In_Subprogram_Or_Concurrent_Unit -- -------------------------------------- @@ -5211,16 +5169,51 @@ package body Sem_Util is Pref := Prefix (Pref); end loop; - if Present (Pref) and then Is_Entity_Name (Pref) then - Ent := Entity (Pref); - end if; - end if; + if Present (Pref) and then Is_Entity_Name (Pref) then + Ent := Entity (Pref); + end if; + end if; + + if Present (Ent) then + Generate_Reference (Ent, New_Prefix); + end if; + end if; + end Insert_Explicit_Dereference; + + ------------------------------------------ + -- Inspect_Deferred_Constant_Completion -- + ------------------------------------------ + + procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + + -- Deferred constant signature + + if Nkind (Decl) = N_Object_Declaration + and then Constant_Present (Decl) + and then No (Expression (Decl)) + + -- No need to check internally generated constants + + and then Comes_From_Source (Decl) - if Present (Ent) then - Generate_Reference (Ent, New_Prefix); + -- The constant is not completed. A full object declaration + -- or a pragma Import complete a deferred constant. + + and then not Has_Completion (Defining_Identifier (Decl)) + then + Error_Msg_N + ("constant declaration requires initialization expression", + Defining_Identifier (Decl)); end if; - end if; - end Insert_Explicit_Dereference; + + Decl := Next (Decl); + end loop; + end Inspect_Deferred_Constant_Completion; ------------------- -- Is_AAMP_Float -- @@ -5433,6 +5426,20 @@ package body Sem_Util is and then not Is_Static_Coextension (N); end Is_Coextension_Root; + ----------------------------- + -- Is_Concurrent_Interface -- + ----------------------------- + + function Is_Concurrent_Interface (T : Entity_Id) return Boolean is + begin + return + Is_Interface (T) + and then + (Is_Protected_Interface (T) + or else Is_Synchronized_Interface (T) + or else Is_Task_Interface (T)); + end Is_Concurrent_Interface; + -------------------------------------- -- Is_Controlling_Limited_Procedure -- -------------------------------------- @@ -5554,7 +5561,24 @@ package body Sem_Util is elsif Ada_Version >= Ada_05 then if Is_Access_Type (Prefix_Type) then - Prefix_Type := Designated_Type (Prefix_Type); + + -- If the access type is pool-specific, and there is no + -- constrained partial view of the designated type, then the + -- designated object is known to be constrained. + + if Ekind (Prefix_Type) = E_Access_Type + and then not Has_Constrained_Partial_View + (Designated_Type (Prefix_Type)) + then + return False; + + -- Otherwise (general access type, or there is a constrained + -- partial view of the designated type), we need to check + -- based on the designated type. + + else + Prefix_Type := Designated_Type (Prefix_Type); + end if; end if; end if; @@ -5677,8 +5701,6 @@ package body Sem_Util is T := Base_Type (Etyp); end loop; end if; - - raise Program_Error; end Is_Descendent_Of; -------------- @@ -5840,13 +5862,13 @@ package body Sem_Util is or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) - -- Special VM case for uTag component, which needs to be - -- defined in this case, but is never initialized as VMs + -- Special VM case for tag components, which need to be + -- defined in this case, but are never initialized as VMs -- are using other dispatching mechanisms. Ignore this - -- uninitialized case. + -- uninitialized case. Note that this applies both to the + -- uTag entry and the main vtable pointer (CPP_Class case). - and then (VM_Target = No_VM - or else Chars (Ent) /= Name_uTag) + and then (VM_Target = No_VM or else not Is_Tag (Ent)) then return False; end if; @@ -6096,7 +6118,7 @@ package body Sem_Util is function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is begin - Note_Possible_Modification (AV); + Note_Possible_Modification (AV, Sure => True); -- We must reject parenthesized variable names. The check for -- Comes_From_Source is present because there are currently @@ -6140,7 +6162,7 @@ package body Sem_Util is if Is_Variable (Expression (AV)) and then Paren_Count (Expression (AV)) = 0 then - Note_Possible_Modification (Expression (AV)); + Note_Possible_Modification (Expression (AV), Sure => True); return True; -- We also allow a non-parenthesized expression that raises @@ -6173,33 +6195,6 @@ 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 -- ----------------------------------- @@ -6328,7 +6323,7 @@ package body Sem_Util is Indx : Node_Id; begin - -- For private type, test corrresponding full type + -- For private type, test corresponding full type if Is_Private_Type (T) then return Is_Potentially_Persistent_Type (Full_View (T)); @@ -6383,6 +6378,42 @@ package body Sem_Util is end if; end Is_Potentially_Persistent_Type; + --------------------------------- + -- Is_Protected_Self_Reference -- + --------------------------------- + + function Is_Protected_Self_Reference (N : Node_Id) return Boolean + is + function In_Access_Definition (N : Node_Id) return Boolean; + -- Returns true if N belongs to an access definition + + -------------------------- + -- In_Access_Definition -- + -------------------------- + + function In_Access_Definition (N : Node_Id) return Boolean + is + P : Node_Id := Parent (N); + begin + while Present (P) loop + if Nkind (P) = N_Access_Definition then + return True; + end if; + P := Parent (P); + end loop; + return False; + end In_Access_Definition; + + -- Start of processing for Is_Protected_Self_Reference + + begin + return Ada_Version >= Ada_05 + and then Is_Entity_Name (N) + and then Is_Protected_Type (Entity (N)) + and then In_Open_Scopes (Entity (N)) + and then not In_Access_Definition (N); + end Is_Protected_Self_Reference; + ----------------------------- -- Is_RCI_Pkg_Spec_Or_Body -- ----------------------------- @@ -6423,60 +6454,13 @@ package body Sem_Util is function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is - D : Entity_Id; - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean; - -- Check that the type is declared by a limited type declaration, - -- or else is derived from a Remote_Type ancestor through private - -- extensions. - - ------------------------------------------------- - -- Comes_From_Limited_Private_Type_Declaration -- - ------------------------------------------------- - - function Comes_From_Limited_Private_Type_Declaration - (E : Entity_Id) return Boolean - is - N : constant Node_Id := Declaration_Node (E); - - begin - if Nkind (N) = N_Private_Type_Declaration - and then Limited_Present (N) - then - return True; - end if; - - if Nkind (N) = N_Private_Extension_Declaration then - return - Comes_From_Limited_Private_Type_Declaration (Etype (E)) - or else - (Is_Remote_Types (Etype (E)) - and then Is_Limited_Record (Etype (E)) - and then Has_Private_Declaration (Etype (E))); - end if; - - return False; - end Comes_From_Limited_Private_Type_Declaration; - - -- Start of processing for Is_Remote_Access_To_Class_Wide_Type - begin - if not (Is_Remote_Call_Interface (E) - or else Is_Remote_Types (E)) - or else Ekind (E) /= E_General_Access_Type - then - return False; - end if; - - D := Designated_Type (E); + -- A remote access to class-wide type is a general access to object type + -- declared in the visible part of a Remote_Types or Remote_Call_ + -- Interface unit. - if Ekind (D) /= E_Class_Wide_Type then - return False; - end if; - - return Comes_From_Limited_Private_Type_Declaration - (Defining_Identifier (Parent (D))); + return Ekind (E) = E_General_Access_Type + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- @@ -6490,8 +6474,7 @@ package body Sem_Util is return (Ekind (E) = E_Access_Subprogram_Type or else (Ekind (E) = E_Record_Type and then Present (Corresponding_Remote_Type (E)))) - and then (Is_Remote_Call_Interface (E) - or else Is_Remote_Types (E)); + and then (Is_Remote_Call_Interface (E) or else Is_Remote_Types (E)); end Is_Remote_Access_To_Subprogram_Type; -------------------- @@ -6546,8 +6529,8 @@ package body Sem_Util is Subp_Decl : Node_Id := Parent (Parent (Proc_Nam)); function Is_Entry (Nam : Node_Id) return Boolean; - -- Determine whether Nam is an entry. Traverse selectors - -- if there are nested selected components. + -- Determine whether Nam is an entry. Traverse selectors if there are + -- nested selected components. -------------- -- Is_Entry -- @@ -7054,11 +7037,8 @@ package body Sem_Util is -- If scope is a package, also clear current values of all -- private entities in the scope. - if Ekind (S) = E_Package - or else - Ekind (S) = E_Generic_Package - or else - Is_Concurrent_Type (S) + if Is_Package_Or_Generic_Package (S) + or else Is_Concurrent_Type (S) then Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; @@ -7194,7 +7174,7 @@ package body Sem_Util is when N_Type_Conversion => return Known_To_Be_Assigned (P); - -- All other references are definitely not knwon to be modifications + -- All other references are definitely not known to be modifications when others => return False; @@ -7317,13 +7297,13 @@ package body Sem_Util is end loop; end; - -- Test for appearing in a conversion that itself appears - -- in an lvalue context, since this should be an lvalue. + -- Test for appearing in a conversion that itself appears in an + -- lvalue context, since this should be an lvalue. when N_Type_Conversion => return May_Be_Lvalue (P); - -- Test for appearence in object renaming declaration + -- Test for appearance in object renaming declaration when N_Object_Renaming_Declaration => return True; @@ -7341,7 +7321,9 @@ package body Sem_Util is ----------------------- procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is - Is_Dynamic : Boolean := False; + Is_Dynamic : Boolean; + -- Indicates whether the context causes nested coextensions to be + -- dynamic or static function Mark_Allocator (N : Node_Id) return Traverse_Result; -- Recognize an allocator node and label it as a dynamic coextension @@ -7477,14 +7459,14 @@ package body Sem_Util is N : Node_Id; begin - -- If we are pointing at a positional parameter, it is a member of - -- a node list (the list of parameters), and the next parameter - -- is the next node on the list, unless we hit a parameter - -- association, in which case we shift to using the chain whose - -- head is the First_Named_Actual in the parent, and then is - -- threaded using the Next_Named_Actual of the Parameter_Association. - -- All this fiddling is because the original node list is in the - -- textual call order, and what we need is the declaration order. + -- If we are pointing at a positional parameter, it is a member of a + -- node list (the list of parameters), and the next parameter is the + -- next node on the list, unless we hit a parameter association, then + -- we shift to using the chain whose head is the First_Named_Actual in + -- the parent, and then is threaded using the Next_Named_Actual of the + -- Parameter_Association. All this fiddling is because the original node + -- list is in the textual call order, and what we need is the + -- declaration order. if Is_List_Member (Actual_Id) then N := Next (Actual_Id); @@ -7675,9 +7657,9 @@ package body Sem_Util is Formal := First_Formal (S); while Present (Formal) loop - -- Match the formals in order. If the corresponding actual - -- is positional, nothing to do. Else scan the list of named - -- actuals to find the one with the right name. + -- Match the formals in order. If the corresponding actual is + -- positional, nothing to do. Else scan the list of named actuals + -- to find the one with the right name. if Present (Actual) and then Nkind (Actual) /= N_Parameter_Association @@ -7795,7 +7777,7 @@ package body Sem_Util is -- Note_Possible_Modification -- -------------------------------- - procedure Note_Possible_Modification (N : Node_Id) is + procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean) is Modification_Comes_From_Source : constant Boolean := Comes_From_Source (Parent (N)); @@ -7875,6 +7857,10 @@ package body Sem_Util is if Comes_From_Source (Exp) or else Modification_Comes_From_Source then + if Has_Pragma_Unmodified (Ent) then + Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent); + end if; + Set_Never_Set_In_Source (Ent, False); end if; @@ -7907,6 +7893,35 @@ package body Sem_Util is end if; Kill_Checks (Ent); + + -- If we are sure this is a modification from source, and we know + -- this modifies a constant, then give an appropriate warning. + + if Overlays_Constant (Ent) + and then Modification_Comes_From_Source + and then Sure + then + declare + A : constant Node_Id := Address_Clause (Ent); + begin + if Present (A) then + declare + Exp : constant Node_Id := Expression (A); + begin + if Nkind (Exp) = N_Attribute_Reference + and then Attribute_Name (Exp) = Name_Address + and then Is_Entity_Name (Prefix (Exp)) + then + Error_Msg_Sloc := Sloc (A); + Error_Msg_NE + ("constant& may be modified via address clause#?", + N, Entity (Prefix (Exp))); + end if; + end; + end if; + end; + end if; + return; end if; end loop; @@ -7919,22 +7934,21 @@ package body Sem_Util is function Object_Access_Level (Obj : Node_Id) return Uint is E : Entity_Id; - -- Returns the static accessibility level of the view denoted - -- by Obj. Note that the value returned is the result of a - -- call to Scope_Depth. Only scope depths associated with - -- dynamic scopes can actually be returned. Since only - -- relative levels matter for accessibility checking, the fact - -- that the distance between successive levels of accessibility - -- is not always one is immaterial (invariant: if level(E2) is - -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)). + -- Returns the static accessibility level of the view denoted by Obj. Note + -- that the value returned is the result of a call to Scope_Depth. Only + -- scope depths associated with dynamic scopes can actually be returned. + -- Since only relative levels matter for accessibility checking, the fact + -- that the distance between successive levels of accessibility 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. + -- 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 -- @@ -7960,11 +7974,14 @@ package body Sem_Util is if Is_Entity_Name (Obj) then E := Entity (Obj); - -- If E is a type then it denotes a current instance. - -- For this case we add one to the normal accessibility - -- level of the type to ensure that current instances - -- are treated as always being deeper than than the level - -- of any visible named access type (see 3.10.2(21)). + if Is_Prival (E) then + E := Prival_Link (E); + end if; + + -- If E is a type then it denotes a current instance. For this case + -- we add one to the normal accessibility level of the type to ensure + -- that current instances are treated as always being deeper than + -- than the level of any visible named access type (see 3.10.2(21)). if Is_Type (E) then return Type_Access_Level (E) + 1; @@ -8004,10 +8021,9 @@ package body Sem_Util is elsif Nkind (Obj) = N_Explicit_Dereference then - -- If the prefix is a selected access discriminant then - -- we make a recursive call on the prefix, which will - -- in turn check the level of the prefix object of - -- the selected discriminant. + -- If the prefix is a selected access discriminant then we make a + -- recursive call on the prefix, which will in turn check the level + -- of the prefix object of the selected discriminant. if Nkind (Prefix (Obj)) = N_Selected_Component and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type @@ -8036,9 +8052,9 @@ package body Sem_Util is then return Object_Access_Level (Expression (Obj)); - -- Function results are objects, so we get either the access level - -- of the function or, in the case of an indirect call, the level of - -- of the access-to-subprogram type. + -- Function results are objects, so we get either the access level of + -- the function or, in the case of an indirect call, the level of the + -- access-to-subprogram type. elsif Nkind (Obj) = N_Function_Call then if Is_Entity_Name (Name (Obj)) then @@ -8102,9 +8118,9 @@ package body Sem_Util is and then Is_Record_Type (Full_View (Btype)) and then not Is_Frozen (Btype) then - -- To indicate that the ancestor depends on a private type, - -- the current Btype is sufficient. However, to check for - -- circular definition we must recurse on the full view. + -- To indicate that the ancestor depends on a private type, the + -- current Btype is sufficient. However, to check for circular + -- definition we must recurse on the full view. Candidate := Trace_Components (Full_View (Btype), True); @@ -8155,6 +8171,48 @@ package body Sem_Util is return Trace_Components (Type_Id, False); end Private_Component; + --------------------------- + -- Primitive_Names_Match -- + --------------------------- + + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is + + function Non_Internal_Name (E : Entity_Id) return Name_Id; + -- Given an internal name, returns the corresponding non-internal name + + ------------------------ + -- Non_Internal_Name -- + ------------------------ + + function Non_Internal_Name (E : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end Non_Internal_Name; + + -- Start of processing for Primitive_Names_Match + + begin + pragma Assert (Present (E1) and then Present (E2)); + + return Chars (E1) = Chars (E2) + or else + (not Is_Internal_Name (Chars (E1)) + and then Is_Internal_Name (Chars (E2)) + and then Non_Internal_Name (E2) = Chars (E1)) + or else + (not Is_Internal_Name (Chars (E2)) + and then Is_Internal_Name (Chars (E1)) + and then Non_Internal_Name (E1) = Chars (E2)) + or else + (Is_Predefined_Dispatching_Operation (E1) + and then Is_Predefined_Dispatching_Operation (E2) + and then Same_TSS (E1, E2)) + or else + (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); + end Primitive_Names_Match; + ----------------------- -- Process_End_Label -- ----------------------- @@ -8166,75 +8224,57 @@ package body Sem_Util is is Loc : Source_Ptr; Nam : Node_Id; + Scop : Entity_Id; Label_Ref : Boolean; -- Set True if reference to end label itself is required Endl : Node_Id; - -- Gets set to the operator symbol or identifier that references - -- the entity Ent. For the child unit case, this is the identifier - -- from the designator. For other cases, this is simply Endl. + -- Gets set to the operator symbol or identifier that references the + -- entity Ent. For the child unit case, this is the identifier from the + -- designator. For other cases, this is simply Endl. - procedure Generate_Parent_Ref (N : Node_Id); - -- N is an identifier node that appears as a parent unit reference - -- in the case where Ent is a child unit. This procedure generates - -- an appropriate cross-reference entry. + procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id); + -- N is an identifier node that appears as a parent unit reference in + -- the case where Ent is a child unit. This procedure generates an + -- appropriate cross-reference entry. E is the corresponding entity. ------------------------- -- Generate_Parent_Ref -- ------------------------- - procedure Generate_Parent_Ref (N : Node_Id) is - Parent_Ent : Entity_Id; - + procedure Generate_Parent_Ref (N : Node_Id; E : Entity_Id) is begin - -- Search up scope stack. The reason we do this is that normal - -- visibility analysis would not work for two reasons. First in - -- some subunit cases, the entry for the parent unit may not be - -- visible, and in any case there can be a local entity that - -- hides the scope entity. - - Parent_Ent := Current_Scope; - while Present (Parent_Ent) loop - if Chars (Parent_Ent) = Chars (N) then - - -- Generate the reference. We do NOT consider this as a - -- reference for unreferenced symbol purposes, but we do - -- force a cross-reference even if the end line does not - -- come from source (the caller already generated the - -- appropriate Typ for this situation). - - Generate_Reference - (Parent_Ent, N, 'r', Set_Ref => False, Force => True); - Style.Check_Identifier (N, Parent_Ent); - return; - end if; + -- If names do not match, something weird, skip reference - Parent_Ent := Scope (Parent_Ent); - end loop; + if Chars (E) = Chars (N) then - -- Fall through means entity was not found -- that's odd, but - -- the appropriate thing is simply to ignore and not generate - -- any cross-reference for this entry. + -- Generate the reference. We do NOT consider this as a reference + -- for unreferenced symbol purposes. - return; + Generate_Reference (E, N, 'r', Set_Ref => False, Force => True); + + if Style_Check then + Style.Check_Identifier (N, E); + end if; + end if; end Generate_Parent_Ref; -- Start of processing for Process_End_Label begin - -- If no node, ignore. This happens in some error situations, - -- and also for some internally generated structures where no - -- end label references are required in any case. + -- If no node, ignore. This happens in some error situations, and + -- also for some internally generated structures where no end label + -- references are required in any case. if No (N) then return; end if; -- Nothing to do if no End_Label, happens for internally generated - -- constructs where we don't want an end label reference anyway. - -- Also nothing to do if Endl is a string literal, which means - -- there was some prior error (bad operator symbol) + -- constructs where we don't want an end label reference anyway. Also + -- nothing to do if Endl is a string literal, which means there was + -- some prior error (bad operator symbol) Endl := End_Label (N); @@ -8246,10 +8286,10 @@ package body Sem_Util is if not In_Extended_Main_Source_Unit (N) then - -- Generally we do not collect references except for the - -- extended main source unit. The one exception is the 'e' - -- entry for a package spec, where it is useful for a client - -- to have the ending information to define scopes. + -- Generally we do not collect references except for the extended + -- main source unit. The one exception is the 'e' entry for a + -- package spec, where it is useful for a client to have the + -- ending information to define scopes. if Typ /= 'e' then return; @@ -8257,8 +8297,8 @@ package body Sem_Util is else Label_Ref := False; - -- For this case, we can ignore any parent references, - -- but we need the package name itself for the 'e' entry. + -- For this case, we can ignore any parent references, but we + -- need the package name itself for the 'e' entry. if Nkind (Endl) = N_Designator then Endl := Identifier (Endl); @@ -8274,17 +8314,23 @@ package body Sem_Util is if Nkind (Endl) = N_Designator then - -- Generate references for the prefix if the END line comes - -- from source (otherwise we do not need these references) + -- Generate references for the prefix if the END line comes from + -- source (otherwise we do not need these references) We climb the + -- scope stack to find the expected entities. if Comes_From_Source (Endl) then - Nam := Name (Endl); + Nam := Name (Endl); + Scop := Current_Scope; while Nkind (Nam) = N_Selected_Component loop - Generate_Parent_Ref (Selector_Name (Nam)); + Scop := Scope (Scop); + exit when No (Scop); + Generate_Parent_Ref (Selector_Name (Nam), Scop); Nam := Prefix (Nam); end loop; - Generate_Parent_Ref (Nam); + if Present (Scop) then + Generate_Parent_Ref (Nam, Scope (Scop)); + end if; end if; Endl := Identifier (Endl); @@ -8300,21 +8346,22 @@ package body Sem_Util is return; end if; - -- If label was really there, then generate a normal reference - -- and then adjust the location in the end label to point past - -- the name (which should almost always be the semicolon). + -- If label was really there, then generate a normal reference and then + -- adjust the location in the end label to point past the name (which + -- should almost always be the semicolon). Loc := Sloc (Endl); if Comes_From_Source (Endl) then - -- If a label reference is required, then do the style check - -- and generate an l-type cross-reference entry for the label + -- If a label reference is required, then do the style check and + -- generate an l-type cross-reference entry for the label if Label_Ref then if Style_Check then Style.Check_Identifier (Endl, Ent); end if; + Generate_Reference (Ent, Endl, 'l', Set_Ref => False); end if; @@ -8375,6 +8422,32 @@ package body Sem_Util is return Token_Node; end Real_Convert; + -------------------- + -- Remove_Homonym -- + -------------------- + + procedure Remove_Homonym (E : Entity_Id) is + Prev : Entity_Id := Empty; + H : Entity_Id; + + begin + if E = Current_Entity (E) then + if Present (Homonym (E)) then + Set_Current_Entity (Homonym (E)); + else + Set_Name_Entity_Id (Chars (E), Empty); + end if; + else + H := Current_Entity (E); + while Present (H) and then H /= E loop + Prev := H; + H := Homonym (H); + end loop; + + Set_Homonym (Prev, Homonym (E)); + end if; + end Remove_Homonym; + --------------------- -- Rep_To_Pos_Flag -- --------------------- @@ -8506,7 +8579,7 @@ package body Sem_Util is function Clear_Analyzed (N : Node_Id) return Traverse_Result; -- Function used to reset Analyzed flags in tree. Note that we do -- not reset Analyzed flags in entities, since there is no need to - -- renalalyze entities, and indeed, it is wrong to do so, since it + -- reanalyze entities, and indeed, it is wrong to do so, since it -- can result in generating auxiliary stuff more than once. -------------------- @@ -8522,16 +8595,12 @@ package body Sem_Util is return OK; end Clear_Analyzed; - function Reset_Analyzed is - new Traverse_Func (Clear_Analyzed); - - Discard : Traverse_Result; - pragma Warnings (Off, Discard); + procedure Reset_Analyzed is new Traverse_Proc (Clear_Analyzed); -- Start of processing for Reset_Analyzed_Flags begin - Discard := Reset_Analyzed (N); + Reset_Analyzed (N); end Reset_Analyzed_Flags; --------------------------- @@ -8813,7 +8882,7 @@ package body Sem_Util is -- Scope_Is_Transient -- ------------------------ - function Scope_Is_Transient return Boolean is + function Scope_Is_Transient return Boolean is begin return Scope_Stack.Table (Scope_Stack.Last).Is_Transient; end Scope_Is_Transient; @@ -8858,6 +8927,22 @@ package body Sem_Util is return False; end Scope_Within_Or_Same; + -------------------- + -- Set_Convention -- + -------------------- + + procedure Set_Convention (E : Entity_Id; Val : Snames.Convention_Id) is + begin + Basic_Set_Convention (E, Val); + + if Is_Type (E) + and then Is_Access_Subprogram_Type (Base_Type (E)) + and then Has_Foreign_Convention (E) + then + Set_Can_Use_Internal_Rep (E, False); + end if; + end Set_Convention; + ------------------------ -- Set_Current_Entity -- ------------------------ @@ -8872,6 +8957,103 @@ package body Sem_Util is Set_Name_Entity_Id (Chars (E), E); end Set_Current_Entity; + --------------------------- + -- Set_Debug_Info_Needed -- + --------------------------- + + procedure Set_Debug_Info_Needed (T : Entity_Id) is + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id); + pragma Inline (Set_Debug_Info_Needed_If_Not_Set); + -- Used to set debug info in a related node if not set already + + -------------------------------------- + -- Set_Debug_Info_Needed_If_Not_Set -- + -------------------------------------- + + procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is + begin + if Present (E) + and then not Needs_Debug_Info (E) + then + Set_Debug_Info_Needed (E); + + -- For a private type, indicate that the full view also needs + -- debug information. + + if Is_Type (E) + and then Is_Private_Type (E) + and then Present (Full_View (E)) + then + Set_Debug_Info_Needed (Full_View (E)); + end if; + end if; + end Set_Debug_Info_Needed_If_Not_Set; + + -- Start of processing for Set_Debug_Info_Needed + + begin + -- Nothing to do if argument is Empty or has Debug_Info_Off set, which + -- indicates that Debug_Info_Needed is never required for the entity. + + if No (T) + or else Debug_Info_Off (T) + then + return; + end if; + + -- Set flag in entity itself. Note that we will go through the following + -- circuitry even if the flag is already set on T. That's intentional, + -- it makes sure that the flag will be set in subsidiary entities. + + Set_Needs_Debug_Info (T); + + -- Set flag on subsidiary entities if not set already + + if Is_Object (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + elsif Is_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Etype (T)); + + if Is_Record_Type (T) then + declare + Ent : Entity_Id := First_Entity (T); + begin + while Present (Ent) loop + Set_Debug_Info_Needed_If_Not_Set (Ent); + Next_Entity (Ent); + end loop; + end; + + elsif Is_Array_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Component_Type (T)); + + declare + Indx : Node_Id := First_Index (T); + begin + while Present (Indx) loop + Set_Debug_Info_Needed_If_Not_Set (Etype (Indx)); + Indx := Next_Index (Indx); + end loop; + end; + + if Is_Packed (T) then + Set_Debug_Info_Needed_If_Not_Set (Packed_Array_Type (T)); + end if; + + elsif Is_Access_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Directly_Designated_Type (T)); + + elsif Is_Private_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Full_View (T)); + + elsif Is_Protected_Type (T) then + Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); + end if; + end if; + end Set_Debug_Info_Needed; + --------------------------------- -- Set_Entity_With_Style_Check -- --------------------------------- @@ -8942,6 +9124,19 @@ package body Sem_Util is end if; end Set_Next_Actual; + ---------------------------------- + -- Set_Optimize_Alignment_Flags -- + ---------------------------------- + + procedure Set_Optimize_Alignment_Flags (E : Entity_Id) is + begin + if Optimize_Alignment = 'S' then + Set_Optimize_Alignment_Space (E); + elsif Optimize_Alignment = 'T' then + Set_Optimize_Alignment_Time (E); + end if; + end Set_Optimize_Alignment_Flags; + ----------------------- -- Set_Public_Status -- ----------------------- @@ -8949,6 +9144,34 @@ package body Sem_Util is procedure Set_Public_Status (Id : Entity_Id) is S : constant Entity_Id := Current_Scope; + function Within_HSS_Or_If (E : Entity_Id) return Boolean; + -- Determines if E is defined within handled statement sequence or + -- an if statement, returns True if so, False otherwise. + + ---------------------- + -- Within_HSS_Or_If -- + ---------------------- + + function Within_HSS_Or_If (E : Entity_Id) return Boolean is + N : Node_Id; + begin + N := Declaration_Node (E); + loop + N := Parent (N); + + if No (N) then + return False; + + elsif Nkind_In (N, N_Handled_Sequence_Of_Statements, + N_If_Statement) + then + return True; + end if; + end loop; + end Within_HSS_Or_If; + + -- Start of processing for Set_Public_Status + begin -- Everything in the scope of Standard is public @@ -8960,14 +9183,15 @@ package body Sem_Util is elsif not Is_Public (S) then return; - -- An object declaration that occurs in a handled sequence of statements - -- is the declaration for a temporary object generated by the expander. - -- It never needs to be made public and furthermore, making it public - -- can cause back end problems if it is of variable size. + -- An object or function declaration that occurs in a handled sequence + -- of statements or within an if statement is the declaration for a + -- temporary object or local subprogram generated by the expander. It + -- never needs to be made public and furthermore, making it public can + -- cause back end problems. - elsif Nkind (Parent (Id)) = N_Object_Declaration - and then - Nkind (Parent (Parent (Id))) = N_Handled_Sequence_Of_Statements + elsif Nkind_In (Parent (Id), N_Object_Declaration, + N_Function_Specification) + and then Within_HSS_Or_If (Id) then return; @@ -8988,6 +9212,42 @@ package body Sem_Util is end if; end Set_Public_Status; + ----------------------------- + -- Set_Referenced_Modified -- + ----------------------------- + + procedure Set_Referenced_Modified (N : Node_Id; Out_Param : Boolean) is + Pref : Node_Id; + + begin + -- Deal with indexed or selected component where prefix is modified + + if Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Selected_Component + then + Pref := Prefix (N); + + -- If prefix is access type, then it is the designated object that is + -- being modified, which means we have no entity to set the flag on. + + if No (Etype (Pref)) or else Is_Access_Type (Etype (Pref)) then + return; + + -- Otherwise chase the prefix + + else + Set_Referenced_Modified (Pref, Out_Param); + end if; + + -- Otherwise see if we have an entity name (only other case to process) + + elsif Is_Entity_Name (N) and then Present (Entity (N)) then + Set_Referenced_As_LHS (Entity (N), not Out_Param); + Set_Referenced_As_Out_Parameter (Entity (N), Out_Param); + end if; + end Set_Referenced_Modified; + ---------------------------- -- Set_Scope_Is_Transient -- ---------------------------- @@ -9092,8 +9352,8 @@ package body Sem_Util is Write_Str (Msg); Write_Name (Chars (E)); - Write_Str (" line "); - Write_Int (Int (Get_Logical_Line_Number (Sloc (N)))); + Write_Str (" from "); + Write_Location (Sloc (N)); Write_Eol; end if; end Trace_Scope; @@ -9217,7 +9477,7 @@ package body Sem_Util is Btyp := Root_Type (Btyp); - -- The accessibility level of anonymous acccess types associated with + -- The accessibility level of anonymous access 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)). @@ -9240,6 +9500,22 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; + -------------------- + -- Ultimate_Alias -- + -------------------- + -- To do: add occurrences calling this new subprogram + + function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is + E : Entity_Id := Prim; + + begin + while Present (Alias (E)) loop + E := Alias (E); + end loop; + + return E; + end Ultimate_Alias; + -------------------------- -- Unit_Declaration_Node -- --------------------------