diff options
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 1807 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 153 |
3 files changed, 1742 insertions, 282 deletions
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index fd40084..258a60c 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -81,15 +81,14 @@ package body Exp_Ch13 is when Attribute_Address => - -- If there is an initialization which did not come from - -- the source program, then it is an artifact of our - -- expansion, and we suppress it. The case we are most - -- concerned about here is the initialization of a packed - -- array to all false, which seems inappropriate for a - -- variable to which an address clause is applied. The - -- expression may itself have been rewritten if the type is a - -- packed array, so we need to examine whether the original - -- node is in the source. + -- If there is an initialization which did not come from the + -- source program, then it is an artifact of our expansion, and we + -- suppress it. The case we are most concerned about here is the + -- initialization of a packed array to all false, which seems + -- inappropriate for variable to which an address clause is + -- applied. The expression may itself have been rewritten if the + -- type is packed array, so we need to examine whether the + -- original node is in the source. declare Decl : constant Node_Id := Declaration_Node (Ent); @@ -139,7 +138,6 @@ package body Exp_Ch13 is -- assignment statement to initialze this value. elsif Is_Access_Type (Ent) then - V := Make_Defining_Identifier (Loc, New_External_Name (Chars (Ent), 'V')); @@ -246,13 +244,14 @@ package body Exp_Ch13 is Delete : Boolean := False; begin - -- For object, with address clause, check alignment is OK + -- Processing for objects with address clauses - if Is_Object (E) then - Apply_Alignment_Check (E, N); + if Is_Object (E) and then Present (Address_Clause (E)) then + Apply_Address_Clause_Check (E, N); + return; - -- Only other items requiring any front end action are - -- types and subprograms. + -- Only other items requiring any front end action are types and + -- subprograms. elsif not Is_Type (E) and then not Is_Subprogram (E) then return; @@ -268,12 +267,12 @@ package body Exp_Ch13 is return; end if; - -- If we are freezing entities defined in protected types, they - -- belong in the enclosing scope, given that the original type - -- has been expanded away. The same is true for entities in task types, - -- in particular the parameter records of entries (Entities in bodies - -- are all frozen within the body). If we are in the task body, this - -- is a proper scope. + -- If we are freezing entities defined in protected types, they belong + -- in the enclosing scope, given that the original type has been + -- expanded away. The same is true for entities in task types, in + -- particular the parameter records of entries (Entities in bodies are + -- all frozen within the body). If we are in the task body, this is a + -- proper scope. if Ekind (E_Scope) = E_Protected_Type or else (Ekind (E_Scope) = E_Task_Type @@ -349,19 +348,26 @@ package body Exp_Ch13 is elsif Is_Subprogram (E) then Freeze_Subprogram (N); + + -- Ada 2005 (AI-251): Remove the freezing node associated with the + -- entities internally used by the frontend to register primitives + -- covering abstract interfaces. The call to Freeze_Subprogram has + -- already expanded the code that fills the corresponding entry in + -- its secondary dispatch table and therefore the code generator + -- has nothing else to do with this freezing node. + + Delete := Present (Abstract_Interface_Alias (E)); end if; - -- Analyze actions generated by freezing. The init_proc contains - -- source expressions that may raise constraint_error, and the - -- assignment procedure for complex types needs checks on individual - -- component assignments, but all other freezing actions should be - -- compiled with all checks off. + -- Analyze actions generated by freezing. The init_proc contains source + -- expressions that may raise Constraint_Error, and the assignment + -- procedure for complex types needs checks on individual component + -- assignments, but all other freezing actions should be compiled with + -- all checks off. if Present (Actions (N)) then Decl := First (Actions (N)); - while Present (Decl) loop - if Nkind (Decl) = N_Subprogram_Body and then (Is_Init_Proc (Defining_Entity (Decl)) or else diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a9b64c7..96378f6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -41,8 +41,6 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Output; use Output; with Opt; use Opt; -with Restrict; use Restrict; -with Rident; use Rident; with Rtsfind; use Rtsfind; with Scans; use Scans; with Scn; use Scn; @@ -172,8 +170,6 @@ package body Sem_Util is (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id is - Obj : Node_Id; - Loc : constant Source_Ptr := Sloc (N); Constraints : List_Id; Decl : Node_Id; @@ -182,6 +178,7 @@ package body Sem_Util is Lo : Node_Id; Subt : Entity_Id; Disc_Type : Entity_Id; + Obj : Node_Id; begin if Nkind (N) = N_Defining_Identifier then @@ -192,13 +189,12 @@ package body Sem_Util is if Is_Array_Type (T) then Constraints := New_List; - for J in 1 .. Number_Dimensions (T) loop - -- Build an array subtype declaration with the nominal - -- subtype and the bounds of the actual. Add the declaration - -- in front of the local declarations for the subprogram, for - -- analysis before any reference to the formal in the body. + -- Build an array subtype declaration with the nominal subtype and + -- the bounds of the actual. Add the declaration in front of the + -- local declarations for the subprogram, for analysis before any + -- reference to the formal in the body. Lo := Make_Attribute_Reference (Loc, @@ -240,7 +236,6 @@ package body Sem_Util is end if; Discr := First_Discriminant (Disc_Type); - while Present (Discr) loop Append_To (Constraints, Make_Selected_Component (Loc, @@ -363,7 +358,6 @@ package body Sem_Util is begin D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); while Present (D) loop - if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, Prefix => New_Copy_Tree (P), @@ -417,7 +411,6 @@ package body Sem_Util is if Ekind (Deaccessed_T) = E_Array_Subtype then Id := First_Index (Deaccessed_T); - while Present (Id) loop Indx_Type := Underlying_Type (Etype (Id)); @@ -439,7 +432,6 @@ package body Sem_Util is then D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); while Present (D) loop - if Denotes_Discriminant (Node (D)) then Remove_Side_Effects (P); return @@ -494,6 +486,59 @@ package body Sem_Util is return Decl; end Build_Component_Subtype; + --------------------------- + -- Build_Default_Subtype -- + --------------------------- + + function Build_Default_Subtype + (T : Entity_Id; + N : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Disc : Entity_Id; + + begin + if not Has_Discriminants (T) or else Is_Constrained (T) then + return T; + end if; + + Disc := First_Discriminant (T); + + if No (Discriminant_Default_Value (Disc)) then + return T; + end if; + + declare + Act : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + Constraints : constant List_Id := New_List; + Decl : Node_Id; + + begin + while Present (Disc) loop + Append_To (Constraints, + New_Copy_Tree (Discriminant_Default_Value (Disc))); + Next_Discriminant (Disc); + end loop; + + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Act, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (T, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constraints))); + + Insert_Action (N, Decl); + Analyze (Decl); + return Act; + end; + end Build_Default_Subtype; + -------------------------------------------- -- Build_Discriminal_Subtype_Of_Component -- -------------------------------------------- @@ -585,7 +630,6 @@ package body Sem_Util is begin if Ekind (T) = E_Array_Subtype then Id := First_Index (T); - while Present (Id) loop if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else Denotes_Discriminant (Type_High_Bound (Etype (Id))) @@ -684,11 +728,13 @@ package body Sem_Util is Append_To (Declarations (Aux_Decls_Node (N)), Decl); Analyze (Decl); - -- Reset True_Constant indication, since we will indeed - -- assign a value to the variable in the binder main. + -- Reset True_Constant indication, since we will indeed assign a value + -- to the variable in the binder main. We also kill the Current_Value + -- and Last_Assignment fields for the same reason. Set_Is_True_Constant (Elab_Ent, False); Set_Current_Value (Elab_Ent, Empty); + Set_Last_Assignment (Elab_Ent, Empty); -- We do not want any further qualification of the name (if we did -- not do this, we would pick up the name of the generic package @@ -733,9 +779,10 @@ package body Sem_Util is else declare - N : Node_Id := First (Expressions (Expr)); + N : Node_Id; begin + N := First (Expressions (Expr)); while Present (N) loop if Cannot_Raise_Constraint_Error (N) then Next (N); @@ -865,52 +912,6 @@ package body Sem_Util is end if; end Check_Fully_Declared; - ----------------------- - -- Check_Obsolescent -- - ----------------------- - - procedure Check_Obsolescent (Nam : Entity_Id; N : Node_Id) is - W : Node_Id; - - begin - -- Note that we always allow obsolescent references in the compiler - -- itself and the run time, since we assume that we know what we are - -- doing in such cases. For example the calls in Ada.Characters.Handling - -- to its own obsolescent subprograms are just fine. - - if Is_Obsolescent (Nam) and then not GNAT_Mode then - Check_Restriction (No_Obsolescent_Features, N); - - if Warn_On_Obsolescent_Feature then - if Is_Package_Or_Generic_Package (Nam) then - Error_Msg_NE ("with of obsolescent package&?", N, Nam); - else - Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); - end if; - - -- Output additional warning if present - - W := Obsolescent_Warning (Nam); - - if Present (W) then - Name_Buffer (1) := '|'; - Name_Buffer (2) := '?'; - Name_Len := 2; - - -- Add characters to message, and output message - - for J in 1 .. String_Length (Strval (W)) loop - Add_Char_To_Name_Buffer ('''); - Add_Char_To_Name_Buffer - (Get_Character (Get_String_Char (Strval (W), J))); - end loop; - - Error_Msg_N (Name_Buffer (1 .. Name_Len), N); - end if; - end if; - end if; - end Check_Obsolescent; - ------------------------------------------ -- Check_Potentially_Blocking_Operation -- ------------------------------------------ @@ -954,6 +955,153 @@ package body Sem_Util is end if; end Check_VMS; + --------------------------------- + -- Collect_Abstract_Interfaces -- + --------------------------------- + + procedure Collect_Abstract_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parent_Interfaces : Boolean := False) + 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 + + ------------------- + -- 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 -- + ------------- + + procedure Collect (Typ : Entity_Id) is + Ancestor : Entity_Id; + Id : Node_Id; + Iface : Entity_Id; + Nod : Node_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)); + + 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; + 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 + + -- Protect the frontend against wrong sources. For example: + + -- package P is + -- type A is tagged null record; + -- type B is new A with private; + -- type C is new A with private; + -- private + -- type B is new C with null record; + -- type C is new B with null record; + -- end P; + + and then Etype (Typ) /= T + then + Ancestor := Etype (Typ); + Collect (Ancestor); + + if Is_Interface (Ancestor) + and then not Exclude_Parent_Interfaces + then + Add_Interface (Ancestor); + end if; + end if; + + -- Traverse the graph of ancestor interfaces + + if Is_Non_Empty_List (Interface_List (Nod)) then + Id := First (Interface_List (Nod)); + while Present (Id) loop + Iface := Etype (Id); + + -- Protect against wrong uses. For example: + -- type I is interface; + -- type O is tagged null record; + -- 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_Ancestor (T, Iface) + then + null; + else + Collect (Iface); + Add_Interface (Iface); + end if; + end if; + + Next (Id); + end loop; + end if; + end Collect; + + -- Start of processing for Collect_Abstract_Interfaces + + begin + pragma Assert (Is_Tagged_Type (T)); + Ifaces_List := New_Elmt_List; + Collect (T); + end Collect_Abstract_Interfaces; + ---------------------------------- -- Collect_Primitive_Operations -- ---------------------------------- @@ -1088,6 +1236,92 @@ 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 -- ----------------------------------- @@ -1097,7 +1331,7 @@ package body Sem_Util is Msg : String; Ent : Entity_Id := Empty; Loc : Source_Ptr := No_Location; - Warn : Boolean := False) return Node_Id + Warn : Boolean := False) return Node_Id is Msgc : String (1 .. Msg'Length + 2); Msgl : Natural; @@ -1130,7 +1364,7 @@ package body Sem_Util is -- Message is a warning, even in Ada 95 case - if Msg (Msg'Length) = '?' then + if Msg (Msg'Last) = '?' then Wmsg := True; -- In Ada 83, all messages are warnings. In the private part and @@ -1247,10 +1481,11 @@ package body Sem_Util is ("\?& will be raised at run time", N, Standard_Constraint_Error, Eloc); end if; + else - Error_Msg_NEL - ("\static expression raises&!", - N, Standard_Constraint_Error, Eloc); + Error_Msg + ("\static expression fails Constraint_Check", Eloc); + Set_Error_Posted (N); end if; end if; end if; @@ -1295,7 +1530,6 @@ package body Sem_Util is begin E := Get_Name_Entity_Id (Chars (N)); - while Present (E) and then Scope (E) /= CS and then (not Transient_Case or else Scope (E) /= Scope (CS)) @@ -1455,8 +1689,8 @@ package body Sem_Util is -------------------------- function Denotes_Discriminant - (N : Node_Id; - Check_Protected : Boolean := False) return Boolean + (N : Node_Id; + Check_Concurrent : Boolean := False) return Boolean is E : Entity_Id; begin @@ -1475,11 +1709,11 @@ package body Sem_Util is return Ekind (E) = E_Discriminant or else - (Check_Protected + (Check_Concurrent and then Ekind (E) = E_In_Parameter and then Present (Discriminal_Link (E)) and then - (Is_Protected_Type (Scope (Discriminal_Link (E))) + (Is_Concurrent_Type (Scope (Discriminal_Link (E))) or else Is_Concurrent_Record_Type (Scope (Discriminal_Link (E))))); @@ -1658,12 +1892,13 @@ package body Sem_Util is ------------------------------- function Enclosing_Lib_Unit_Entity return Entity_Id is - Unit_Entity : Entity_Id := Current_Scope; + Unit_Entity : Entity_Id; begin -- Look for enclosing library unit entity by following scope links. -- Equivalent to, but faster than indexing through the scope stack. + Unit_Entity := Current_Scope; while (Present (Scope (Unit_Entity)) and then Scope (Unit_Entity) /= Standard_Standard) and not Is_Child_Unit (Unit_Entity) @@ -1679,9 +1914,10 @@ package body Sem_Util is ----------------------------- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is - Current_Node : Node_Id := N; + Current_Node : Node_Id; begin + Current_Node := N; while Present (Current_Node) and then Nkind (Current_Node) /= N_Compilation_Unit loop @@ -1837,7 +2073,6 @@ package body Sem_Util is -- entity in the scope. Prev := First_Entity (Current_Scope); - while Present (Prev) and then Next_Entity (Prev) /= E loop @@ -2049,12 +2284,29 @@ package body Sem_Util is -- Warn if new entity hides an old one - if Warn_On_Hiding - and then Present (C) - and then Length_Of_Name (Chars (C)) /= 1 - and then Comes_From_Source (C) - and then Comes_From_Source (Def_Id) - and then In_Extended_Main_Source_Unit (Def_Id) + if Warn_On_Hiding and then Present (C) + + -- 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. + + and then Length_Of_Name (Chars (C)) /= 1 + + -- Don't warn for non-source eneities + + and then Comes_From_Source (C) + and then Comes_From_Source (Def_Id) + + -- Don't warn unless entity in question is in extended main source + + and then In_Extended_Main_Source_Unit (Def_Id) + + -- Finally, the hidden entity must be either immediately visible + -- or use visible (from a used package) + + and then + (Is_Immediately_Visible (C) + or else + Is_Potentially_Use_Visible (C)) then Error_Msg_Sloc := Sloc (C); Error_Msg_N ("declaration hides &#?", Def_Id); @@ -2074,7 +2326,7 @@ package body Sem_Util is if Is_Array_Type (T) then Error_Msg_Node_2 := T; Error_Msg_NE - ("component type& of type& is limited", N, Component_Type (T)); + ("\component type& of type& is limited", N, Component_Type (T)); Explain_Limited_Type (Component_Type (T), N); elsif Is_Record_Type (T) then @@ -2177,7 +2429,6 @@ package body Sem_Util is Search : loop if Nkind (Alt) /= N_Pragma then Choice := First (Discrete_Choices (Alt)); - while Present (Choice) loop -- Others choice, always matches @@ -2406,7 +2657,6 @@ package body Sem_Util is and then Is_Derived_Type (Typ) and then Present (Stored_Constraint (Typ)) then - -- If the type is a tagged type with inherited discriminants, -- use the stored constraint on the parent in order to find -- the values of discriminants that are otherwise hidden by an @@ -2426,16 +2676,13 @@ package body Sem_Util is begin D := First_Discriminant (Etype (Typ)); C := First_Elmt (Stored_Constraint (Typ)); - - while Present (D) - and then Present (C) - loop + while Present (D) and then Present (C) loop if Chars (Discrim_Name) = Chars (D) then if Is_Entity_Name (Node (C)) and then Entity (Node (C)) = Entity (Discrim) then - -- D is renamed by Discrim, whose value is - -- given in Assoc. + -- D is renamed by Discrim, whose value is given in + -- Assoc. null; @@ -2449,7 +2696,7 @@ package body Sem_Util is exit Find_Constraint; end if; - D := Next_Discriminant (D); + Next_Discriminant (D); Next_Elmt (C); end loop; end; @@ -2805,13 +3052,54 @@ package body Sem_Util is end Get_Name_Entity_Id; --------------------------- + -- Get_Subprogram_Entity -- + --------------------------- + + function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is + Nam : Node_Id; + Proc : Entity_Id; + + begin + if Nkind (Nod) = N_Accept_Statement then + Nam := Entry_Direct_Name (Nod); + else + Nam := Name (Nod); + end if; + + if Nkind (Nam) = N_Explicit_Dereference then + Proc := Etype (Prefix (Nam)); + elsif Is_Entity_Name (Nam) then + Proc := Entity (Nam); + else + return Empty; + end if; + + if Is_Object (Proc) then + Proc := Etype (Proc); + end if; + + if Ekind (Proc) = E_Access_Subprogram_Type then + Proc := Directly_Designated_Type (Proc); + end if; + + if not Is_Subprogram (Proc) + and then Ekind (Proc) /= E_Subprogram_Type + then + return Empty; + else + return Proc; + end if; + end Get_Subprogram_Entity; + + --------------------------- -- Get_Referenced_Object -- --------------------------- function Get_Referenced_Object (N : Node_Id) return Node_Id is - R : Node_Id := N; + R : Node_Id; begin + R := N; while Is_Entity_Name (R) and then Present (Renamed_Object (Entity (R))) loop @@ -2862,9 +3150,64 @@ package body Sem_Util is -- and the procedure that holds the body of the task is held in its -- underlying type. + -- This is an odd function, why not have Task_Body_Procedure do + -- the following digging??? + 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) return Boolean is + Typ : Entity_Id; + + begin + pragma Assert (Is_Record_Type (Tagged_Type) + and then Is_Tagged_Type (Tagged_Type)); + + -- Handle private types + + if Present (Full_View (Tagged_Type)) then + Typ := Full_View (Tagged_Type); + else + Typ := Tagged_Type; + end if; + + loop + if Is_Interface (Typ) + or else (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 -- ----------------------- @@ -2914,6 +3257,330 @@ package body Sem_Util is end if; end Has_Access_Values; + ------------------------------ + -- Has_Compatible_Alignment -- + ------------------------------ + + function Has_Compatible_Alignment + (Obj : Entity_Id; + Expr : Node_Id) return Alignment_Result + is + function Has_Compatible_Alignment_Internal + (Obj : Entity_Id; + Expr : Node_Id; + Default : Alignment_Result) return Alignment_Result; + -- This is the internal recursive function that actually does the work. + -- There is one additional parameter, which says what the result should + -- be if no alignment information is found, and there is no definite + -- indication of compatible alignments. At the outer level, this is set + -- to Unknown, but for internal recursive calls in the case where types + -- are known to be correct, it is set to Known_Compatible. + + --------------------------------------- + -- Has_Compatible_Alignment_Internal -- + --------------------------------------- + + function Has_Compatible_Alignment_Internal + (Obj : Entity_Id; + Expr : Node_Id; + Default : Alignment_Result) return Alignment_Result + is + Result : Alignment_Result := Known_Compatible; + -- Set to result if Problem_Prefix or Problem_Offset returns True. + -- Note that once a value of Known_Incompatible is set, it is sticky + -- and does not get changed to Unknown (the value in Result only gets + -- worse as we go along, never better). + + procedure Check_Offset (Offs : Uint); + -- Called when Expr is a selected or indexed component with Offs set + -- to resp Component_First_Bit or Component_Size. Checks that if the + -- offset is specified it is compatible with the object alignment + -- requirements. The value in Result is modified accordingly. + + procedure Check_Prefix; + -- Checks the prefix recursively in the case where the expression + -- is an indexed or selected component. + + procedure Set_Result (R : Alignment_Result); + -- If R represents a worse outcome (unknown instead of known + -- compatible, or known incompatible), then set Result to R. + + ------------------ + -- Check_Offset -- + ------------------ + + procedure Check_Offset (Offs : Uint) is + begin + -- Unspecified or zero offset is always OK + + if Offs = No_Uint or else Offs = Uint_0 then + null; + + -- If we do not know required alignment, any non-zero offset is + -- a potential problem (but certainly may be OK, so result is + -- unknown). + + elsif Unknown_Alignment (Obj) then + Set_Result (Unknown); + + -- If we know the required alignment, see if offset is compatible + + else + if Offs mod (System_Storage_Unit * Alignment (Obj)) /= 0 then + Set_Result (Known_Incompatible); + end if; + end if; + end Check_Offset; + + ------------------ + -- Check_Prefix -- + ------------------ + + procedure Check_Prefix is + begin + -- The subtlety here is that in doing a recursive call to check + -- the prefix, we have to decide what to do in the case where we + -- don't find any specific indication of an alignment problem. + + -- At the outer level, we normally set Unknown as the result in + -- this case, since we can only set Known_Compatible if we really + -- know that the alignment value is OK, but for the recursive + -- call, in the case where the types match, and we have not + -- specified a peculiar alignment for the object, we are only + -- concerned about suspicious rep clauses, the default case does + -- not affect us, since the compiler will, in the absence of such + -- rep clauses, ensure that the alignment is correct. + + if Default = Known_Compatible + or else + (Etype (Obj) = Etype (Expr) + and then (Unknown_Alignment (Obj) + or else + Alignment (Obj) = Alignment (Etype (Obj)))) + then + Set_Result + (Has_Compatible_Alignment_Internal + (Obj, Prefix (Expr), Known_Compatible)); + + -- In all other cases, we need a full check on the prefix + + else + Set_Result + (Has_Compatible_Alignment_Internal + (Obj, Prefix (Expr), Unknown)); + end if; + end Check_Prefix; + + ---------------- + -- Set_Result -- + ---------------- + + procedure Set_Result (R : Alignment_Result) is + begin + if R > Result then + Result := R; + end if; + end Set_Result; + + -- Start of processing for Has_Compatible_Alignment_Internal + + begin + -- If Expr is a selected component, we must make sure there is no + -- potentially troublesome component clause, and that the record is + -- not packed. + + if Nkind (Expr) = N_Selected_Component then + + -- Packed record always generate unknown alignment + + if Is_Packed (Etype (Prefix (Expr))) then + Set_Result (Unknown); + end if; + + -- Check possible bad component offset and check prefix + + Check_Offset + (Component_Bit_Offset (Entity (Selector_Name (Expr)))); + Check_Prefix; + + -- If Expr is an indexed component, we must make sure there is no + -- potentially troublesome Component_Size clause and that the array + -- is not bit-packed. + + elsif Nkind (Expr) = N_Indexed_Component then + + -- Bit packed array always generates unknown alignment + + if Is_Bit_Packed_Array (Etype (Prefix (Expr))) then + Set_Result (Unknown); + end if; + + -- Check possible bad component size and check prefix + + Check_Offset (Component_Size (Etype (Prefix (Expr)))); + Check_Prefix; + end if; + + -- Case where we know the alignment of the object + + if Known_Alignment (Obj) then + declare + ObjA : constant Uint := Alignment (Obj); + ExpA : Uint := No_Uint; + SizA : Uint := No_Uint; + + begin + -- If alignment of Obj is 1, then we are always OK + + if ObjA = 1 then + Set_Result (Known_Compatible); + + -- Alignment of Obj is greater than 1, so we need to check + + else + -- See if Expr is an object with known alignment + + if Is_Entity_Name (Expr) + and then Known_Alignment (Entity (Expr)) + then + ExpA := Alignment (Entity (Expr)); + + -- Otherwise, we can use the alignment of the type of + -- Expr given that we already checked for + -- discombobulating rep clauses for the cases of indexed + -- and selected components above. + + elsif Known_Alignment (Etype (Expr)) then + ExpA := Alignment (Etype (Expr)); + end if; + + -- If we got an alignment, see if it is acceptable + + if ExpA /= No_Uint then + if ExpA < ObjA then + Set_Result (Known_Incompatible); + end if; + + -- Case of Expr alignment unknown + + else + Set_Result (Default); + end if; + + -- See if size is given. If so, check that it is not too + -- small for the required alignment. + -- See if Expr is an object with known alignment + + if Is_Entity_Name (Expr) + and then Known_Static_Esize (Entity (Expr)) + then + SizA := Esize (Entity (Expr)); + + -- Otherwise, we check the object size of the Expr type + + elsif Known_Static_Esize (Etype (Expr)) then + SizA := Esize (Etype (Expr)); + end if; + + -- If we got a size, see if it is a multiple of the Obj + -- alignment, if not, then the alignment cannot be + -- acceptable, since the size is always a multiple of the + -- alignment. + + if SizA /= No_Uint then + if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then + Set_Result (Known_Incompatible); + end if; + end if; + end if; + end; + + -- If we can't find the result by direct comparison of alignment + -- values, then there is still one case that we can determine known + -- result, and that is when we can determine that the types are the + -- same, and no alignments are specified. Then we known that the + -- alignments are compatible, even if we don't know the alignment + -- value in the front end. + + elsif Etype (Obj) = Etype (Expr) then + + -- Types are the same, but we have to check for possible size + -- and alignments on the Expr object that may make the alignment + -- different, even though the types are the same. + + if Is_Entity_Name (Expr) then + + -- First check alignment of the Expr object. Any alignment less + -- than Maximum_Alignment is worrisome since this is the case + -- where we do not know the alignment of Obj. + + if Known_Alignment (Entity (Expr)) + and then + UI_To_Int (Alignment (Entity (Expr))) + < Ttypes.Maximum_Alignment + then + Set_Result (Unknown); + + -- Now check size of Expr object. Any size that is not an + -- even multiple of Maxiumum_Alignment is also worrisome + -- since it may cause the alignment of the object to be less + -- than the alignment of the type. + + elsif Known_Static_Esize (Entity (Expr)) + and then + (UI_To_Int (Esize (Entity (Expr))) mod + (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)) + /= 0 + then + Set_Result (Unknown); + + -- Otherwise same type is decisive + + else + Set_Result (Known_Compatible); + end if; + end if; + + -- Another case to deal with is when there is an explicit size or + -- alignment clause when the types are not the same. If so, then the + -- result is Unknown. We don't need to do this test if the Default is + -- Unknown, since that result will be set in any case. + + elsif Default /= Unknown + and then (Has_Size_Clause (Etype (Expr)) + or else + Has_Alignment_Clause (Etype (Expr))) + then + Set_Result (Unknown); + + -- If no indication found, set default + + else + Set_Result (Default); + end if; + + -- Return worst result found + + return Result; + end Has_Compatible_Alignment_Internal; + + -- Start of processing for Has_Compatible_Alignment + + begin + -- If Obj has no specified alignment, then set alignment from the type + -- alignment. Perhaps we should always do this, but for sure we should + -- do it when there is an address clause since we can do more if the + -- alignment is known. + + if Unknown_Alignment (Obj) then + Set_Alignment (Obj, Alignment (Etype (Obj))); + end if; + + -- Now do the internal call that does all the work + + return Has_Compatible_Alignment_Internal (Obj, Expr, Unknown); + end Has_Compatible_Alignment; + ---------------------- -- Has_Declarations -- ---------------------- @@ -2992,6 +3659,59 @@ package body Sem_Util is end Has_Infinities; ------------------------ + -- Has_Null_Exclusion -- + ------------------------ + + function Has_Null_Exclusion (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Access_Definition | + N_Access_Function_Definition | + N_Access_Procedure_Definition | + N_Access_To_Object_Definition | + N_Allocator | + N_Derived_Type_Definition | + N_Function_Specification | + N_Subtype_Declaration => + return Null_Exclusion_Present (N); + + when N_Component_Definition | + N_Formal_Object_Declaration | + N_Object_Renaming_Declaration => + if Present (Subtype_Mark (N)) then + return Null_Exclusion_Present (N); + else pragma Assert (Present (Access_Definition (N))); + return Null_Exclusion_Present (Access_Definition (N)); + end if; + + when N_Discriminant_Specification => + if Nkind (Discriminant_Type (N)) = N_Access_Definition then + return Null_Exclusion_Present (Discriminant_Type (N)); + else + return Null_Exclusion_Present (N); + end if; + + when N_Object_Declaration => + if Nkind (Object_Definition (N)) = N_Access_Definition then + return Null_Exclusion_Present (Object_Definition (N)); + else + return Null_Exclusion_Present (N); + end if; + + when N_Parameter_Specification => + if Nkind (Parameter_Type (N)) = N_Access_Definition then + return Null_Exclusion_Present (Parameter_Type (N)); + else + return Null_Exclusion_Present (N); + end if; + + when others => + return False; + + end case; + end Has_Null_Exclusion; + + ------------------------ -- Has_Null_Extension -- ------------------------ @@ -3028,6 +3748,175 @@ package body Sem_Util is end if; end Has_Null_Extension; + -------------------------------------- + -- Has_Preelaborable_Initialization -- + -------------------------------------- + + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is + Has_PE : Boolean; + + procedure Check_Components (E : Entity_Id); + -- Check component/discriminant chain, sets Has_PE False if a component + -- or discriminant does not meet the preelaborable initialization rules. + + ---------------------- + -- Check_Components -- + ---------------------- + + procedure Check_Components (E : Entity_Id) is + Ent : Entity_Id; + Exp : Node_Id; + + begin + -- Loop through entities of record or protected type + + Ent := E; + while Present (Ent) loop + + -- We are interested only in components and discriminants + + if Ekind (Ent) = E_Component + 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 + -- tag fields are examples of such entitires. For these + -- cases, we just test the type of the entity. + + if Present (Declaration_Node (Ent)) then + Exp := Expression (Declaration_Node (Ent)); + else + Exp := Empty; + end if; + + -- A component has PI if it has no default expression and + -- the component type has PI. + + if No (Exp) then + if not Has_Preelaborable_Initialization (Etype (Ent)) then + Has_PE := False; + exit; + end if; + + -- Or if expression obeys rules for preelaboration. For + -- now we approximate this by testing if the default + -- expression is a static expression or if it is an + -- access attribute reference. + + -- This is an approximation, it is probably incomplete??? + + elsif Is_Static_Expression (Exp) then + null; + + elsif Nkind (Exp) = N_Attribute_Reference + and then (Attribute_Name (Exp) = Name_Access + or else + Attribute_Name (Exp) = Name_Unchecked_Access + or else + Attribute_Name (Exp) = Name_Unrestricted_Access) + then + null; + + else + Has_PE := False; + exit; + end if; + end if; + + Next_Entity (Ent); + end loop; + end Check_Components; + + -- Start of processing for Has_Preelaborable_Initialization + + begin + -- Immediate return if already marked as known preelaborable init + + if Known_To_Have_Preelab_Init (E) then + return True; + end if; + + -- All elementary types have preelaborable initialization + + if Is_Elementary_Type (E) then + Has_PE := True; + + -- Array types have PI if the component type has PI + + elsif Is_Array_Type (E) then + Has_PE := Has_Preelaborable_Initialization (Component_Type (E)); + + -- Record types have PI if all components have PI + + elsif Is_Record_Type (E) then + Has_PE := True; + Check_Components (First_Entity (E)); + + -- Another check here, if this is a controlled type, see if it has a + -- user defined Initialize procedure. If so, then there is a special + -- rule that means this type does not have PI. + + if Is_Controlled (E) + and then Present (Primitive_Operations (E)) + then + declare + P : Elmt_Id; + + 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; + + Next_Elmt (P); + end loop; + end; + end if; + + -- Protected types, must not have entries, and components must meet + -- same set of rules as for record components. + + elsif Is_Protected_Type (E) then + if Has_Entries (E) then + Has_PE := False; + else + Has_PE := True; + Check_Components (First_Entity (E)); + Check_Components (First_Private_Entity (E)); + end if; + + -- A derived type has preelaborable initialization if its parent type + -- has preelaborable initialization and (in the case of a derived record + -- extension) if the non-inherited components all have preelaborable + -- initialization. However, a user-defined controlled type with an + -- overriding Initialize procedure does not have preelaborable + -- initialization. + + -- TBD ??? + + -- Type System.Address always has preelaborable initialization + + elsif Is_RTE (E, RE_Address) then + Has_PE := True; + + -- In all other cases, type does not have preelaborable init + + else + return False; + end if; + + if Has_PE then + Set_Known_To_Have_Preelab_Init (E); + end if; + + return Has_PE; + end Has_Preelaborable_Initialization; + --------------------------- -- Has_Private_Component -- --------------------------- @@ -3072,7 +3961,6 @@ package body Sem_Util is Component := First_Component (Btype); while Present (Component) loop - if Has_Private_Component (Etype (Component)) then return True; end if; @@ -3150,7 +4038,6 @@ package body Sem_Util is elsif Is_Record_Type (Typ) then Comp := First_Component (Typ); - while Present (Comp) loop if Has_Tagged_Component (Etype (Comp)) then return True; @@ -3171,9 +4058,11 @@ package body Sem_Util is ----------------- function In_Instance return Boolean is - S : Entity_Id := Current_Scope; + Curr_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop @@ -3182,7 +4071,23 @@ package body Sem_Util is or else Ekind (S) = E_Procedure) and then Is_Generic_Instance (S) then - return True; + + -- A child instance is always compiled in the context of a parent + -- instance. Nevertheless, the actuals are not analyzed in an + -- instance context. We detect this case by examining the current + -- compilation unit, which must be a child instance, and checking + -- that it is not currently on the scope stack. + + if Is_Child_Unit (Curr_Unit) + and then + Nkind (Unit (Cunit (Current_Sem_Unit))) + = N_Package_Instantiation + and then not In_Open_Scopes (Curr_Unit) + then + return False; + else + return True; + end if; end if; S := Scope (S); @@ -3196,9 +4101,10 @@ package body Sem_Util is ---------------------- function In_Instance_Body return Boolean is - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop @@ -3226,9 +4132,10 @@ package body Sem_Util is ----------------------------- function In_Instance_Not_Visible return Boolean is - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop @@ -3256,9 +4163,10 @@ package body Sem_Util is ------------------------------ function In_Instance_Visible_Part return Boolean is - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop @@ -3281,9 +4189,10 @@ package body Sem_Util is ---------------------- function In_Package_Body return Boolean is - S : Entity_Id := Current_Scope; + S : Entity_Id; begin + S := Current_Scope; while Present (S) and then S /= Standard_Standard loop @@ -3366,8 +4275,8 @@ package body Sem_Util is -- designated types of the interpretations of the original node. Set_Etype (N, Any_Type); - Get_First_Interp (New_Prefix, I, It); + Get_First_Interp (New_Prefix, I, It); while Present (It.Nam) loop T := It.Typ; @@ -3395,7 +4304,6 @@ package body Sem_Util is or else Nkind (New_Prefix) = N_Indexed_Component then Pref := Prefix (New_Prefix); - while Present (Pref) and then (Nkind (Pref) = N_Selected_Component @@ -3478,7 +4386,12 @@ package body Sem_Util is or else Ekind (E) = E_Protected_Type) and then In_Open_Scopes (E)) - -- Current instance of type + -- Current instance of type, either directly or as rewritten + -- reference to the current object. + + or else (Is_Entity_Name (Original_Node (Obj)) + and then Present (Entity (Original_Node (Obj))) + 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) @@ -3700,21 +4613,26 @@ package body Sem_Util is -- A heap object is constrained by its initial value - -- Ada 2005 AI-363:if the designated type is a type with a - -- constrained partial view, the resulting heap object is not - -- constrained, and a renaming of the component is now unsafe. - - if Is_Access_Type (Prefix_Type) - and then - not Has_Constrained_Partial_View - (Designated_Type (Prefix_Type)) - then - return False; + -- Ada 2005 (AI-363): Always assume the object could be mutable in + -- the dereferenced case, since the access value might denote an + -- unconstrained aliased object, whereas in Ada 95 the designated + -- object is guaranteed to be constrained. A worst-case assumption + -- has to apply in Ada 2005 because we can't tell at compile time + -- whether the object is "constrained by its initial value" + -- (despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are + -- semantic rules -- these rules are acknowledged to need fixing). + + if Ada_Version < Ada_05 then + if Is_Access_Type (Prefix_Type) + or else Nkind (P) = N_Explicit_Dereference + then + return False; + end if; - elsif Nkind (P) = N_Explicit_Dereference - and then not Has_Constrained_Partial_View (Prefix_Type) - then - return False; + elsif Ada_Version >= Ada_05 then + if Is_Access_Type (Prefix_Type) then + Prefix_Type := Designated_Type (Prefix_Type); + end if; end if; Comp := @@ -3723,6 +4641,8 @@ package body Sem_Util is -- As per AI-0017, the renaming is illegal in a generic body, -- even if the subtype is indefinite. + -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable + if not Is_Constrained (Prefix_Type) and then (not Is_Indefinite_Subtype (Prefix_Type) or else @@ -3732,7 +4652,7 @@ package body Sem_Util is and then (Is_Declared_Within_Variant (Comp) or else Has_Discriminant_Dependent_Constraint (Comp)) - and then not P_Aliased + and then (not P_Aliased or else Ada_Version >= Ada_05) then return True; @@ -3911,7 +4831,6 @@ package body Sem_Util is begin Indx := First_Index (Typ); while Present (Indx) loop - if Etype (Indx) = Any_Type then return False; @@ -4008,7 +4927,6 @@ package body Sem_Util is begin Ent := First_Entity (Typ); - while Present (Ent) loop if Chars (Ent) = Name_uController then null; @@ -4075,8 +4993,8 @@ package body Sem_Util is and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition then Comp_List := Component_List (Type_Definition (Parent (Typ))); - Discr := First_Discriminant (Typ); + Discr := First_Discriminant (Typ); while Present (Discr) loop if Nkind (Parent (Discr)) = N_Discriminant_Specification then Discr_Val := Expression (Parent (Discr)); @@ -4108,7 +5026,6 @@ package body Sem_Util is -- Check that each component present is fully initialized Comp_Elmt := First_Elmt (Components); - while Present (Comp_Elmt) loop Comp_Id := Node (Comp_Elmt); @@ -4202,60 +5119,6 @@ package body Sem_Util is end if; end Is_Local_Variable_Reference; - --------------- - -- Is_Lvalue -- - --------------- - - function Is_Lvalue (N : Node_Id) return Boolean is - P : constant Node_Id := Parent (N); - - begin - case Nkind (P) is - - -- Test left side of assignment - - when N_Assignment_Statement => - return N = Name (P); - - -- Test prefix of component or attribute - - when N_Attribute_Reference | - N_Expanded_Name | - N_Explicit_Dereference | - N_Indexed_Component | - N_Reference | - N_Selected_Component | - N_Slice => - return N = Prefix (P); - - -- Test subprogram parameter (we really should check the - -- parameter mode, but it is not worth the trouble) - - when N_Function_Call | - N_Procedure_Call_Statement | - N_Accept_Statement | - N_Parameter_Association => - return True; - - -- Test for appearing in a conversion that itself appears - -- in an lvalue context, since this should be an lvalue. - - when N_Type_Conversion => - return Is_Lvalue (P); - - -- Test for appearence in object renaming declaration - - when N_Object_Renaming_Declaration => - return True; - - -- All other references are definitely not Lvalues - - when others => - return False; - - end case; - end Is_Lvalue; - ------------------------- -- Is_Object_Reference -- ------------------------- @@ -4839,6 +5702,8 @@ package body Sem_Util is begin if Kind = N_Return_Statement or else + Kind = N_Extended_Return_Statement + or else Kind = N_Goto_Statement or else Kind = N_Raise_Statement @@ -5145,6 +6010,10 @@ package body Sem_Util is Kill_Checks (Ent); Set_Current_Value (Ent, Empty); + if Ekind (Ent) = E_Variable then + Set_Last_Assignment (Ent, Empty); + end if; + if not Can_Never_Be_Null (Ent) then Set_Is_Known_Non_Null (Ent, False); end if; @@ -5202,13 +6071,11 @@ package body Sem_Util is Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S)); end if; - -- If this is a block or nested package, deal with parent + -- If this is a not a subprogram, deal with parents - if Ekind (S) = E_Block - or else (Ekind (S) = E_Package - and then not Is_Library_Level_Entity (S)) - then + if not Is_Subprogram (S) then S := Scope (S); + exit Scope_Loop when S = Standard_Standard; else exit Scope_Loop; end if; @@ -5229,6 +6096,250 @@ package body Sem_Util is end if; end Kill_Size_Check_Code; + -------------------------- + -- Known_To_Be_Assigned -- + -------------------------- + + function Known_To_Be_Assigned (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + case Nkind (P) is + + -- Test left side of assignment + + when N_Assignment_Statement => + return N = Name (P); + + -- Function call arguments are never lvalues + + when N_Function_Call => + return False; + + -- Positional parameter for procedure or accept call + + when N_Procedure_Call_Statement | + N_Accept_Statement + => + declare + Proc : Entity_Id; + Form : Entity_Id; + Act : Node_Id; + + begin + Proc := Get_Subprogram_Entity (P); + + if No (Proc) then + return False; + end if; + + -- If we are not a list member, something is strange, so + -- be conservative and return False. + + if not Is_List_Member (N) then + return False; + end if; + + -- We are going to find the right formal by stepping forward + -- through the formals, as we step backwards in the actuals. + + Form := First_Formal (Proc); + Act := N; + loop + -- If no formal, something is weird, so be conservative + -- and return False. + + if No (Form) then + return False; + end if; + + Prev (Act); + exit when No (Act); + Next_Formal (Form); + end loop; + + return Ekind (Form) /= E_In_Parameter; + end; + + -- Named parameter for procedure or accept call + + when N_Parameter_Association => + declare + Proc : Entity_Id; + Form : Entity_Id; + + begin + Proc := Get_Subprogram_Entity (Parent (P)); + + if No (Proc) then + return False; + end if; + + -- Loop through formals to find the one that matches + + Form := First_Formal (Proc); + loop + -- If no matching formal, that's peculiar, some kind of + -- previous error, so return False to be conservative. + + if No (Form) then + return False; + end if; + + -- Else test for match + + if Chars (Form) = Chars (Selector_Name (P)) then + return Ekind (Form) /= E_In_Parameter; + end if; + + Next_Formal (Form); + end loop; + end; + + -- Test for appearing in a conversion that itself appears + -- in an lvalue context, since this should be an lvalue. + + when N_Type_Conversion => + return Known_To_Be_Assigned (P); + + -- All other references are definitely not knwon to be modifications + + when others => + return False; + + end case; + end Known_To_Be_Assigned; + + ------------------- + -- May_Be_Lvalue -- + ------------------- + + function May_Be_Lvalue (N : Node_Id) return Boolean is + P : constant Node_Id := Parent (N); + + begin + case Nkind (P) is + + -- Test left side of assignment + + when N_Assignment_Statement => + return N = Name (P); + + -- Test prefix of component or attribute + + when N_Attribute_Reference | + N_Expanded_Name | + N_Explicit_Dereference | + N_Indexed_Component | + N_Reference | + N_Selected_Component | + N_Slice => + return N = Prefix (P); + + -- Function call arguments are never lvalues + + when N_Function_Call => + return False; + + -- Positional parameter for procedure or accept call + + when N_Procedure_Call_Statement | + N_Accept_Statement + => + declare + Proc : Entity_Id; + Form : Entity_Id; + Act : Node_Id; + + begin + Proc := Get_Subprogram_Entity (P); + + if No (Proc) then + return True; + end if; + + -- If we are not a list member, something is strange, so + -- be conservative and return True. + + if not Is_List_Member (N) then + return True; + end if; + + -- We are going to find the right formal by stepping forward + -- through the formals, as we step backwards in the actuals. + + Form := First_Formal (Proc); + Act := N; + loop + -- If no formal, something is weird, so be conservative + -- and return True. + + if No (Form) then + return True; + end if; + + Prev (Act); + exit when No (Act); + Next_Formal (Form); + end loop; + + return Ekind (Form) /= E_In_Parameter; + end; + + -- Named parameter for procedure or accept call + + when N_Parameter_Association => + declare + Proc : Entity_Id; + Form : Entity_Id; + + begin + Proc := Get_Subprogram_Entity (Parent (P)); + + if No (Proc) then + return True; + end if; + + -- Loop through formals to find the one that matches + + Form := First_Formal (Proc); + loop + -- If no matching formal, that's peculiar, some kind of + -- previous error, so return True to be conservative. + + if No (Form) then + return True; + end if; + + -- Else test for match + + if Chars (Form) = Chars (Selector_Name (P)) then + return Ekind (Form) /= E_In_Parameter; + end if; + + Next_Formal (Form); + end loop; + end; + + -- 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 + + when N_Object_Renaming_Declaration => + return True; + + -- All other references are definitely not Lvalues + + when others => + return False; + + end case; + end May_Be_Lvalue; + ------------------------- -- New_External_Entity -- ------------------------- @@ -5508,7 +6619,6 @@ package body Sem_Util is Actual := First_Named; Found := False; - while Present (Actual) loop if Chars (Selector_Name (Actual)) = Chars (Formal) then Found := True; @@ -5589,7 +6699,6 @@ package body Sem_Util is -- attached to the list of associations. Actual := First (Actuals); - while Present (Actual) loop if Nkind (Actual) = N_Parameter_Association and then Actual /= Last @@ -5736,9 +6845,9 @@ package body Sem_Util 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 + -- 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 @@ -5839,6 +6948,189 @@ package body Sem_Util is end if; end Object_Access_Level; + -------------------------------------- + -- Overrides_Synchronized_Primitive -- + -------------------------------------- + + function Overrides_Synchronized_Primitive + (Def_Id : Entity_Id; + First_Hom : Entity_Id; + Ifaces_List : Elist_Id; + In_Scope : Boolean := True) return Entity_Id + is + Candidate : Entity_Id; + Hom : Entity_Id; + + function Matches_Prefixed_View_Profile + (Subp_Params : List_Id; + Over_Params : List_Id) return Boolean; + -- Determine if a subprogram parameter profile (Subp_Params) + -- matches that of a potentially overriden subprogram (Over_Params). + -- Determine if the type of first parameter in the list Over_Params + -- is an implemented interface, that is to say, the interface is in + -- Ifaces_List. + + ----------------------------------- + -- Matches_Prefixed_View_Profile -- + ----------------------------------- + + function Matches_Prefixed_View_Profile + (Subp_Params : List_Id; + Over_Params : List_Id) return Boolean + is + Subp_Param : Node_Id; + Over_Param : Node_Id; + Over_Param_Typ : Entity_Id; + + function Is_Implemented (Iface : Entity_Id) return Boolean; + -- Determine if Iface is implemented by the current task or + -- protected type. + + -------------------- + -- Is_Implemented -- + -------------------- + + function Is_Implemented (Iface : Entity_Id) return Boolean is + Iface_Elmt : Elmt_Id; + + begin + Iface_Elmt := First_Elmt (Ifaces_List); + while Present (Iface_Elmt) loop + if Node (Iface_Elmt) = Iface then + return True; + end if; + + Next_Elmt (Iface_Elmt); + end loop; + + return False; + end Is_Implemented; + + -- Start of processing for Matches_Prefixed_View_Profile + + begin + Subp_Param := First (Subp_Params); + Over_Param := First (Over_Params); + + if Nkind (Parameter_Type (Over_Param)) = N_Access_Definition then + Over_Param_Typ := + Etype (Subtype_Mark (Parameter_Type (Over_Param))); + else + Over_Param_Typ := Etype (Parameter_Type (Over_Param)); + end if; + + -- The first parameter of the potentially overriden subprogram + -- must be an interface implemented by Def_Id. + + if not Is_Interface (Over_Param_Typ) + or else not Is_Implemented (Over_Param_Typ) + then + return False; + end if; + + -- This may be a primitive declared after a task or protected type. + -- We need to skip the first parameter since it is irrelevant. + + if not In_Scope then + Subp_Param := Next (Subp_Param); + end if; + Over_Param := Next (Over_Param); + + while Present (Subp_Param) and then Present (Over_Param) loop + + -- The two parameters must be mode conformant and both types + -- must be the same. + + if Ekind (Defining_Identifier (Subp_Param)) /= + Ekind (Defining_Identifier (Over_Param)) + or else + Etype (Parameter_Type (Subp_Param)) /= + Etype (Parameter_Type (Over_Param)) + then + return False; + end if; + + Next (Subp_Param); + Next (Over_Param); + end loop; + + -- One of the two lists contains more parameters than the other + + if Present (Subp_Param) or else Present (Over_Param) then + return False; + end if; + + return True; + end Matches_Prefixed_View_Profile; + + -- Start of processing for Overrides_Synchronized_Primitive + + begin + -- At this point the caller should have collected the interfaces + -- implemented by the synchronized type. + + pragma Assert (Present (Ifaces_List)); + + -- Traverse the homonym chain, looking at a potentially overriden + -- subprogram that belongs to an implemented interface. + + Hom := First_Hom; + while Present (Hom) loop + Candidate := Hom; + + -- Entries can override abstract or null interface procedures + + 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) + or else Null_Present (Parent (Candidate))) + then + while Present (Alias (Candidate)) loop + Candidate := Alias (Candidate); + end loop; + + if Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Candidate))) + then + return Candidate; + end if; + + -- Procedure can override abstract or null interface procedures + + 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) + or else Null_Present (Parent (Candidate))) + and then Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Candidate))) + then + return Candidate; + + -- Function can override abstract interface functions + + 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 Matches_Prefixed_View_Profile + (Parameter_Specifications (Parent (Def_Id)), + Parameter_Specifications (Parent (Candidate))) + and then Etype (Result_Definition (Parent (Def_Id))) = + Etype (Result_Definition (Parent (Candidate))) + then + return Candidate; + end if; + + Hom := Homonym (Hom); + end loop; + + return Empty; + end Overrides_Synchronized_Primitive; + ----------------------- -- Private_Component -- ----------------------- @@ -6296,8 +7588,7 @@ package body Sem_Util is procedure Reset_Analyzed_Flags (N : Node_Id) is - function Clear_Analyzed - (N : Node_Id) return Traverse_Result; + 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 @@ -6307,9 +7598,7 @@ package body Sem_Util is -- Clear_Analyzed -- -------------------- - function Clear_Analyzed - (N : Node_Id) return Traverse_Result - is + function Clear_Analyzed (N : Node_Id) return Traverse_Result is begin if not Has_Extension (N) then Set_Analyzed (N, False); @@ -6335,19 +7624,41 @@ package body Sem_Util is --------------------------- function Safe_To_Capture_Value - (N : Node_Id; - Ent : Entity_Id) return Boolean + (N : Node_Id; + Ent : Entity_Id; + Cond : Boolean := False) return Boolean is begin -- The only entities for which we track constant values are variables, - -- out parameters and in out parameters, so check if we have this case. + -- which are not renamings, out parameters and in out parameters, so + -- check if we have this case. - if Ekind (Ent) /= E_Variable - and then - Ekind (Ent) /= E_Out_Parameter - and then - Ekind (Ent) /= E_In_Out_Parameter + if (Ekind (Ent) = E_Variable and then No (Renamed_Object (Ent))) + or else + Ekind (Ent) = E_Out_Parameter + or else + Ekind (Ent) = E_In_Out_Parameter then + null; + + -- For conditionals, we also allow constants, loop parameters and all + -- formals, including in parameters. + + elsif Cond + and then + (Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_Loop_Parameter + or else + Ekind (Ent) = E_In_Parameter) + then + null; + + -- For all other cases, not just unsafe, but impossible to capture + -- Current_Value, since the above are the only entities which have + -- Current_Value fields. + + else return False; end if; @@ -6355,8 +7666,6 @@ package body Sem_Util is -- be going on in these cases which we cannot necessarily track. -- Also skip any variable for which an address clause is given. - -- Should we have a flag Has_Address_Clause ??? - if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) or else Present (Address_Clause (Ent)) @@ -6366,7 +7675,7 @@ package body Sem_Util is -- OK, all above conditions are met. We also require that the scope -- of the reference be the same as the scope of the entity, not - -- counting packages and blocks. + -- counting packages and blocks and loops. declare E_Scope : constant Entity_Id := Scope (Ent); @@ -6378,8 +7687,10 @@ package body Sem_Util is exit when R_Scope = E_Scope; if Ekind (R_Scope) /= E_Package - and then - Ekind (R_Scope) /= E_Block + and then + Ekind (R_Scope) /= E_Block + and then + Ekind (R_Scope) /= E_Loop then return False; else @@ -6390,7 +7701,12 @@ package body Sem_Util is -- We also require that the reference does not appear in a context -- where it is not sure to be executed (i.e. a conditional context - -- or an exception handler). + -- or an exception handler). We skip this if Cond is True, since the + -- capturing of values from conditional tests handles this ok. + + if Cond then + return True; + end if; declare Desc : Node_Id; @@ -6398,7 +7714,8 @@ package body Sem_Util is begin Desc := N; - P := Parent (N); + + P := Parent (N); while Present (P) loop if Nkind (P) = N_If_Statement or else Nkind (P) = N_Case_Statement @@ -6552,10 +7869,8 @@ package body Sem_Util is then if Nkind (N) = N_Identifier then Nod := N; - elsif Nkind (N) = N_Expanded_Name then Nod := Selector_Name (N); - else return; end if; @@ -6797,7 +8112,6 @@ package body Sem_Util is declare Comp : Entity_Id; - begin Comp := First_Entity (Ent); while Present (Comp) loop @@ -6837,7 +8151,26 @@ package body Sem_Util is if Ekind (Btyp) = E_Anonymous_Access_Type and then not Is_Local_Anonymous_Access (Typ) -- Ada 2005 (AI-230) then - return Scope_Depth (Standard_Standard); + + -- If this is a return_subtype, the accessibility level is that + -- of the result subtype of the enclosing function. + + if Ekind (Scope (Btyp)) = E_Return_Statement then + declare + Scop : Entity_Id; + begin + Scop := Scope (Scope (Btyp)); + while Present (Scop) loop + exit when Ekind (Scop) = E_Function; + Scop := Scope (Scop); + end loop; + + return Scope_Depth (Scope (Scop)); + end; + + else + return Scope_Depth (Standard_Standard); + end if; end if; Btyp := Root_Type (Btyp); @@ -6846,7 +8179,14 @@ package body Sem_Util is -- discriminants is that of the current instance of the type, and -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)). - if Ekind (Typ) = E_Anonymous_Access_Type + -- AI-402: access discriminants have accessibility based on the + -- object rather than the type in Ada2005, so the above + -- paragraph doesn't apply + + -- ??? Needs completion with rules from AI-416 + + if Ada_Version <= Ada_95 + and then Ekind (Typ) = E_Anonymous_Access_Type and then Present (Associated_Node_For_Itype (Typ)) and then Nkind (Associated_Node_For_Itype (Typ)) = N_Discriminant_Specification @@ -6872,6 +8212,8 @@ package body Sem_Util is return N; end if; + -- Isn't there some better way to express the following ??? + while Nkind (N) /= N_Abstract_Subprogram_Declaration and then Nkind (N) /= N_Formal_Package_Declaration and then Nkind (N) /= N_Function_Instantiation @@ -6938,6 +8280,24 @@ package body Sem_Util is end if; end Universal_Interpretation; + --------------- + -- Unqualify -- + --------------- + + function Unqualify (Expr : Node_Id) return Node_Id is + begin + -- Recurse to handle unlikely case of multiple levels of qualification + + if Nkind (Expr) = N_Qualified_Expression then + return Unqualify (Expression (Expr)); + + -- Normal case, not a qualified expression + + else + return Expr; + end if; + end Unqualify; + ---------------------- -- Within_Init_Proc -- ---------------------- @@ -7096,11 +8456,11 @@ package body Sem_Util is and then not Comes_From_Source (Found_Type) then Error_Msg_NE - ("found an access type with designated}!", + ("\\found an access type with designated}!", Expr, Designated_Type (Found_Type)); else if From_With_Type (Found_Type) then - Error_Msg_NE ("found incomplete}!", Expr, Found_Type); + Error_Msg_NE ("\\found incomplete}!", Expr, Found_Type); Error_Msg_NE ("\possibly missing with_clause on&", Expr, Scope (Found_Type)); @@ -7112,11 +8472,11 @@ package body Sem_Util is -- Normal case of one type found, some other type expected else - -- If the names of the two types are the same, see if some - -- number of levels of qualification will help. Don't try - -- more than three levels, and if we get to standard, it's - -- no use (and probably represents an error in the compiler) - -- Also do not bother with internal scope names. + -- If the names of the two types are the same, see if some number + -- of levels of qualification will help. Don't try more than three + -- levels, and if we get to standard, it's no use (and probably + -- represents an error in the compiler) Also do not bother with + -- internal scope names. declare Expec_Scope : Entity_Id; @@ -7154,7 +8514,7 @@ package body Sem_Util is if Is_Entity_Name (Expr) and then Is_Package_Or_Generic_Package (Entity (Expr)) then - Error_Msg_N ("found package name!", Expr); + Error_Msg_N ("\\found package name!", Expr); elsif Is_Entity_Name (Expr) and then @@ -7167,7 +8527,8 @@ package body Sem_Util is ("found procedure name, possibly missing Access attribute!", Expr); else - Error_Msg_N ("found procedure name instead of function!", Expr); + Error_Msg_N + ("\\found procedure name instead of function!", Expr); end if; elsif Nkind (Expr) = N_Function_Call @@ -7196,10 +8557,10 @@ package body Sem_Util is and then Present (Parent (Found_Type)) and then Nkind (Parent (Found_Type)) = N_Full_Type_Declaration then - Error_Msg_NE ("found premature usage of}!", Expr, Found_Type); + Error_Msg_NE ("\\found premature usage of}!", Expr, Found_Type); else - Error_Msg_NE ("found}!", Expr, Found_Type); + Error_Msg_NE ("\\found}!", Expr, Found_Type); end if; Error_Msg_Qual_Level := 0; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index c6f847b..ad2404b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -87,6 +87,14 @@ package Sem_Util is -- Determine whether a selected component has a type that depends on -- discriminants, and build actual subtype for it if so. + function Build_Default_Subtype + (T : Entity_Id; + N : Node_Id) return Entity_Id; + -- If T is an unconstrained type with defaulted discriminants, build a + -- subtype constrained by the default values, insert the subtype + -- declaration in the tree before N, and return the entity of that + -- subtype. Otherwise, simply return T. + function Build_Discriminal_Subtype_Of_Component (T : Entity_Id) return Node_Id; -- Determine whether a record component has a type that depends on @@ -108,12 +116,6 @@ package Sem_Util is -- place error message on node N. Used in object declarations, type -- conversions, qualified expressions. - procedure Check_Obsolescent (Nam : Entity_Id; N : Node_Id); - -- Nam is either a subprogram or a (generic) package entity. This procedure - -- checks if the Is_Obsolescent flag is set and if so, outputs appropriate - -- diagnostics (it also checks the appropriate restriction). N is the node - -- to which error messages are attached. - procedure Check_Potentially_Blocking_Operation (N : Node_Id); -- N is one of the statement forms that is a potentially blocking -- operation. If it appears within a protected action, emit warning. @@ -124,12 +126,26 @@ package Sem_Util is -- with OpenVMS ports. The argument is the construct in question -- and is used to post the error message. + procedure Collect_Abstract_Interfaces + (T : Entity_Id; + Ifaces_List : out Elist_Id; + Exclude_Parent_Interfaces : Boolean := False); + -- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are + -- directly or indirectly implemented by T. Exclude_Parent_Interfaces is + -- used to avoid addition of inherited interfaces to the generated list. + function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id; -- Called upon type derivation and extension. We scan the declarative -- part in which the type appears, and collect subprograms that have -- 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; @@ -174,13 +190,14 @@ package Sem_Util is -- ignoring any child unit prefixes. function Denotes_Discriminant - (N : Node_Id; - Check_Protected : Boolean := False) return Boolean; + (N : Node_Id; + Check_Concurrent : Boolean := False) return Boolean; -- Returns True if node N is an Entity_Name node for a discriminant. - -- If the flag Check_Protected is true, function also returns true - -- when N denotes the discriminal of the discriminant of a protected + -- If the flag Check_Concurrent is true, function also returns true + -- when N denotes the discriminal of the discriminant of a concurrent -- type. This is necessary to disable some optimizations on private - -- components of protected types. + -- components of protected types, and constraint checks on entry + -- families constrained by discriminants. function Depends_On_Discriminant (N : Node_Id) return Boolean; -- Returns True if N denotes a discriminant or if N is a range, a subtype @@ -356,6 +373,12 @@ package Sem_Util is -- which is the innermost visible entity with the given name. See the -- body of Sem_Ch8 for further details on handling of entity visibility. + function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id; + -- Nod is either a procedure call statement, or a function call, or + -- an accept statement node. This procedure finds the Entity_Id of the + -- related subprogram or entry and returns it, or if no subprogram can + -- be found, returns Empty. + function Get_Referenced_Object (N : Node_Id) return Node_Id; -- Given a node, return the renamed object if the node represents -- a renamed object, otherwise return the node unchanged. The node @@ -380,6 +403,33 @@ package Sem_Util is -- T contains access values (happens for generic formals in some -- cases), then False is returned. + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); + -- Result of Has_Compatible_Alignment test, description found below. Note + -- that the values are arranged in increasing order of problematicness. + + function Has_Abstract_Interfaces (Tagged_Type : Entity_Id) return Boolean; + -- Returns true if Tagged_Type implements some abstract interface + + function Has_Compatible_Alignment + (Obj : Entity_Id; + Expr : Node_Id) return Alignment_Result; + -- Obj is an object entity, and expr is a node for an object reference. If + -- the alignment of the object referenced by Expr is known to be compatible + -- with the alignment of Obj (i.e. is larger or the same), then the result + -- is Known_Compatible. If the alignment of the object referenced by Expr + -- is known to be less than the alignment of Obj, then Known_Incompatible + -- is returned. If neither condition can be reliably established at compile + -- time, then Unknown is returned. This is used to determine if alignment + -- checks are required for address clauses, and also whether copies must + -- be made when objects are passed by reference. + -- + -- Note: Known_Incompatible does not mean that at run time the alignment + -- of Expr is known to be wrong for Obj, just that it can be determined + -- that alignments have been explicitly or implicitly specified which + -- are incompatible (whereas Unknown means that even this is not known). + -- The appropriate reaction of a caller to Known_Incompatible is to treat + -- it as Unknown, but issue a warning that there may be an alignment error. + function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations @@ -392,6 +442,13 @@ package Sem_Util is -- Determines if the range of the floating-point type E includes -- infinities. Returns False if E is not a floating-point type. + function Has_Null_Exclusion (N : Node_Id) return Boolean; + -- Determine whether node N has a null exclusion + + function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; + -- Return True iff type E has preelaborable initialiation as defined in + -- Ada 2005 (see AI-161 for details of the definition of this attribute). + function Has_Private_Component (Type_Id : Entity_Id) return Boolean; -- Check if a type has a (sub)component of a private type that has not -- yet received a full declaration. @@ -479,7 +536,7 @@ package Sem_Util is -- Returns True if Object is the name of a subcomponent that -- depends on discriminants of a variable whose nominal subtype -- is unconstrained and not indefinite, and the variable is - -- not aliased. Otherwise returns False. The nodes passed + -- not aliased. Otherwise returns False. The nodes passed -- to this function are assumed to denote objects. function Is_Dereferenced (N : Node_Id) return Boolean; @@ -521,15 +578,6 @@ package Sem_Util is -- E is a subprogram. Return True is E is an implicit operation inherited -- by a derived type declarations. - function Is_Lvalue (N : Node_Id) return Boolean; - -- Determines if N could be an lvalue (e.g. an assignment left hand side). - -- This determination is conservative, it must never answer False if N is - -- an lvalue, but it can answer True when N is not an lvalue. An lvalue is - -- defined as any expression which appears in a context where a name is - -- required by the syntax, and the identity, rather than merely the value - -- of the node is needed (for example, the prefix of an Access attribute - -- is in this category). - function Is_Library_Level_Entity (E : Entity_Id) return Boolean; -- A library-level declaration is one that is accessible from Standard, -- i.e. a library unit or an entity declared in a library package. @@ -621,7 +669,7 @@ package Sem_Util is procedure Kill_Current_Values; -- This procedure is called to clear all constant indications from all -- entities in the current scope and in any parent scopes if the current - -- scope is a block or a pacakage (and that recursion continues to the + -- scope is a block or a package (and that recursion continues to the -- top scope that is not a block or a package). This is used when the -- sequential flow-of-control assumption is violated (occurence of a -- label, head of a loop, or start of an exception handler). The effect @@ -644,6 +692,24 @@ package Sem_Util is -- code is present, this size check code is killed, since the object -- will not be allocated by the program. + function Known_To_Be_Assigned (N : Node_Id) return Boolean; + -- The node N is an entity reference. This function determines whether the + -- reference is for sure an assignment of the entity, returning True if + -- so. This differs from May_Be_Lvalue in that it defaults in the other + -- direction. Cases which may possibly be assignments but are not known to + -- be may return True from May_Be_Lvalue, but False from this function. + + function May_Be_Lvalue (N : Node_Id) return Boolean; + -- Determines if N could be an lvalue (e.g. an assignment left hand side). + -- An lvalue is defined as any expression which appears in a context where + -- a name is required by the syntax, and the identity, rather than merely + -- the value of the node is needed (for example, the prefix of an Access + -- attribute is in this category). Note that, as implied by the name, this + -- test is conservative. If it cannot be sure that N is NOT an lvalue, then + -- it returns True. It tries hard to get the answer right, but it is hard + -- to guarantee this in all cases. Note that it is more possible to give + -- correct answer if the tree is fully analyzed. + function New_External_Entity (Kind : Entity_Kind; Scope_Id : Entity_Id; @@ -706,6 +772,18 @@ package Sem_Util is -- For convenience, qualified expressions applied to object names -- are also allowed as actuals for this function. + function Overrides_Synchronized_Primitive + (Def_Id : Entity_Id; + First_Hom : Entity_Id; + Ifaces_List : Elist_Id; + In_Scope : Boolean := True) return Entity_Id; + -- Determine whether entry or subprogram Def_Id overrides a primitive + -- operation that belongs to one of the interfaces in Ifaces_List. A + -- specific homonym chain can be specified by setting First_Hom. Flag + -- In_Scope is used to designate whether the entry or subprogram was + -- declared inside the scope of the synchronized type or after. Return + -- the overriden entity or Empty. + function Private_Component (Type_Id : Entity_Id) return Entity_Id; -- Returns some private component (if any) of the given Type_Id. -- Used to enforce the rules on visibility of operations on composite @@ -761,14 +839,24 @@ package Sem_Util is function Safe_To_Capture_Value (N : Node_Id; - Ent : Entity_Id) return Boolean; - -- The caller is interested in capturing a value (either the current - -- value, or an indication that the value is non-null) for the given - -- entity Ent. This value can only be captured if sequential execution - -- semantics can be properly guaranteed so that a subsequent reference - -- will indeed be sure that this current value indication is correct. - -- The node N is the construct which resulted in the possible capture - -- of the value (this is used to check if we are in a conditional). + Ent : Entity_Id; + Cond : Boolean := False) return Boolean; + -- The caller is interested in capturing a value (either the current value, + -- or an indication that the value is non-null) for the given entity Ent. + -- This value can only be captured if sequential execution semantics can be + -- properly guaranteed so that a subsequent reference will indeed be sure + -- that this current value indication is correct. The node N is the + -- construct which resulted in the possible capture of the value (this + -- is used to check if we are in a conditional). + -- + -- Cond is used to skip the test for being inside a conditional. It is used + -- in the case of capturing values from if/while tests, which already do a + -- proper job of handling scoping issues without this help. + -- + -- The only entities whose values can be captured are OUT and IN OUT formal + -- parameters, and variables unless Cond is True, in which case we also + -- allow IN formals, loop parameters and constants, where we cannot ever + -- capture actual value information, but we can capture conditional tests. function Same_Name (N1, N2 : Node_Id) return Boolean; -- Determine if two (possibly expanded) names are the same name @@ -863,6 +951,10 @@ package Sem_Util is function Universal_Interpretation (Opnd : Node_Id) return Entity_Id; -- Yields universal_Integer or Universal_Real if this is a candidate + function Unqualify (Expr : Node_Id) return Node_Id; + -- Removes any qualifications from Expr. For example, for T1'(T2'(X)), + -- this returns X. If Expr is not a qualified expression, returns Expr. + function Within_Init_Proc return Boolean; -- Determines if Current_Scope is within an init proc @@ -882,5 +974,6 @@ private pragma Inline (Set_Current_Entity); pragma Inline (Set_Name_Entity_Id); pragma Inline (Set_Size_Info); + pragma Inline (Unqualify); end Sem_Util; |