diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 301 |
1 files changed, 201 insertions, 100 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1505b..679d0ee 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -333,7 +333,7 @@ package body Sem_Util is -- Add_Global_Declaration -- ---------------------------- - procedure Add_Global_Declaration (N : Node_Id) is + procedure Add_Global_Declaration (Decl : Node_Id) is Aux_Node : constant Node_Id := Aux_Decls_Node (Cunit (Current_Sem_Unit)); begin @@ -341,8 +341,8 @@ package body Sem_Util is Set_Declarations (Aux_Node, New_List); end if; - Append_To (Declarations (Aux_Node), N); - Analyze (N); + Append_To (Declarations (Aux_Node), Decl); + Analyze (Decl); end Add_Global_Declaration; -------------------------------- @@ -3025,7 +3025,7 @@ package body Sem_Util is -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate - -- occurrences of the expression (RM 6.4.1(20/3)). + -- occurrences of the expression (RM 6.4.1(6.20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate @@ -3110,48 +3110,105 @@ package body Sem_Util is end loop; end if; - -- Handle discrete associations + -- Handle named associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if not Box_Present (Assoc) then - Choice := First (Choices (Assoc)); - while Present (Choice) loop + Handle_Association : declare - -- For now we skip discriminants since it requires - -- performing the analysis in two phases: first one - -- analyzing discriminants and second one analyzing - -- the rest of components since discriminants are - -- evaluated prior to components: too much extra - -- work to detect a corner case??? + procedure Collect_Expression_Ids (Expr : Node_Id); + -- Collect identifiers in association expression Expr - if Nkind (Choice) in N_Has_Entity - and then Present (Entity (Choice)) - and then Ekind (Entity (Choice)) = E_Discriminant - then - null; + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id); + -- Collect identifiers in an association expression + -- Expr for each choice in Choices. + + ---------------------------- + -- Collect_Expression_Ids -- + ---------------------------- - elsif Box_Present (Assoc) then - null; + procedure Collect_Expression_Ids (Expr : Node_Id) is + Comp_Expr : Node_Id; + begin + if not Analyzed (Expr) then + Comp_Expr := New_Copy_Tree (Expr); + Set_Parent (Comp_Expr, Parent (N)); + Preanalyze_Without_Errors (Comp_Expr); else - if not Analyzed (Expression (Assoc)) then - Comp_Expr := - New_Copy_Tree (Expression (Assoc)); - Set_Parent (Comp_Expr, Parent (N)); - Preanalyze_Without_Errors (Comp_Expr); + Comp_Expr := Expr; + end if; + + Collect_Identifiers (Comp_Expr); + end Collect_Expression_Ids; + + -------------------------------- + -- Handle_Association_Choices -- + -------------------------------- + + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id) + is + Choice : Node_Id := First (Choices); + + begin + while Present (Choice) loop + + -- For now skip discriminants since it requires + -- performing analysis in two phases: first one + -- analyzing discriminants and second analyzing + -- the rest of components since discriminants + -- are evaluated prior to components: too much + -- extra work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then + Ekind (Entity (Choice)) = E_Discriminant + then + null; + else - Comp_Expr := Expression (Assoc); + Collect_Expression_Ids (Expr); end if; - Collect_Identifiers (Comp_Expr); - end if; + Next (Choice); + end loop; + end Handle_Association_Choices; - Next (Choice); - end loop; - end if; + begin + if not Box_Present (Assoc) then + if Nkind (Assoc) = N_Component_Association then + Handle_Association_Choices + (Choices (Assoc), Expression (Assoc)); + + elsif + Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Defining_Identifier (Assoc)) + then + Handle_Association_Choices + (Discrete_Choices (Assoc), Expression (Assoc)); + + -- Nkind (Assoc) = N_Iterated_Component_Association + -- with iterator_specification, or + -- Nkind (Assoc) = N_Iterated_Element_Association + -- with loop_parameter_specification + -- or iterator_specification + -- + -- It seems that we might also need to deal with + -- iterable/iterator_names and iterator_filters + -- within iterator_specifications, and range bounds + -- within loop_parameter_specifications, but the + -- utility of doing that seems very low. ??? + + else + Collect_Expression_Ids (Expression (Assoc)); + end if; + end if; + end Handle_Association; Next (Assoc); end loop; @@ -5619,10 +5676,8 @@ package body Sem_Util is -- to start scanning from the incomplete view, which is earlier on -- the entity chain. - elsif Nkind (Parent (B_Type)) = N_Full_Type_Declaration - and then Present (Incomplete_View (Parent (B_Type))) - then - Id := Incomplete_View (Parent (B_Type)); + elsif Present (Incomplete_View (B_Type)) then + Id := Incomplete_View (B_Type); -- If T is a derived from a type with an incomplete view declared -- elsewhere, that incomplete view is irrelevant, we want the @@ -5662,6 +5717,7 @@ package body Sem_Util is or else Is_Primitive (Id)) and then Parent_Kind (Parent (Id)) not in N_Formal_Subprogram_Declaration + and then not Is_Child_Unit (Id) then Is_Prim := False; @@ -6578,6 +6634,30 @@ package body Sem_Util is return Is_Class_Wide_Type (Typ) or else Needs_Finalization (Typ); end CW_Or_Needs_Finalization; + ------------------------- + -- Default_Constructor -- + ------------------------- + + function Default_Constructor (Typ : Entity_Id) return Entity_Id is + Construct : Elmt_Id; + begin + pragma Assert (Is_Type (Typ)); + if No (Constructor_Name (Typ)) or else No (Constructor_List (Typ)) then + return Empty; + end if; + + Construct := First_Elmt (Constructor_List (Typ)); + while Present (Construct) loop + if Parameter_Count (Elists.Node (Construct)) = 1 then + return Elists.Node (Construct); + end if; + + Next_Elmt (Construct); + end loop; + + return Empty; + end Default_Constructor; + --------------------- -- Defining_Entity -- --------------------- @@ -7946,6 +8026,7 @@ package body Sem_Util is -- but the error should be posted on it, not on the component. elsif Ekind (E) = E_Discriminant + and then Is_Not_Self_Hidden (E) and then Present (Scope (Def_Id)) and then Scope (Def_Id) /= Current_Scope then @@ -7971,7 +8052,10 @@ package body Sem_Util is -- Avoid cascaded messages with duplicate components in -- derived types. - if Ekind (E) in E_Component | E_Discriminant then + if Ekind (E) = E_Component + or else (Ekind (E) = E_Discriminant + and then Is_Not_Self_Hidden (E)) + then return; end if; end if; @@ -8002,20 +8086,7 @@ package body Sem_Util is -- If we fall through, declaration is OK, at least OK enough to continue - -- If Def_Id is a discriminant or a record component we are in the midst - -- of inheriting components in a derived record definition. Preserve - -- their Ekind and Etype. - - if Ekind (Def_Id) in E_Discriminant | E_Component then - null; - - -- If a type is already set, leave it alone (happens when a type - -- declaration is reanalyzed following a call to the optimizer). - - elsif Present (Etype (Def_Id)) then - null; - - else + if No (Etype (Def_Id)) then Set_Etype (Def_Id, Any_Type); -- avoid cascaded errors end if; @@ -8063,12 +8134,20 @@ package body Sem_Util is loop Ren := Renamed_Object (Id); + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + if Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; - if Is_Entity_Name (Ren) then + elsif Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced @@ -8081,14 +8160,6 @@ package body Sem_Util is Id := Entity (Ren); end if; - -- The reference renames a function result. Check the original - -- node in case expansion relocates the function call. - - -- Ren : ... renames Func_Call; - - elsif Nkind (Original_Node (Ren)) = N_Function_Call then - exit; - -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. @@ -8843,9 +8914,10 @@ package body Sem_Util is -------------------------- procedure Find_Overlaid_Entity - (N : Node_Id; - Ent : out Entity_Id; - Off : out Boolean) + (N : Node_Id; + Ent : out Entity_Id; + Ovrl_Typ : out Entity_Id; + Off : out Boolean) is pragma Assert (Nkind (N) = N_Attribute_Definition_Clause @@ -8867,8 +8939,9 @@ package body Sem_Util is -- In the second case, the expr is either Y'Address, or recursively a -- constant that eventually references Y'Address. - Ent := Empty; - Off := False; + Ent := Empty; + Ovrl_Typ := Empty; + Off := False; Expr := Expression (N); @@ -8898,6 +8971,8 @@ package body Sem_Util is end if; end loop; + Ovrl_Typ := Etype (Expr); + -- This loop checks the form of the prefix for an entity, using -- recursion to deal with intermediate components. @@ -8916,8 +8991,10 @@ package body Sem_Util is pragma Assert (not Expander_Active and then Is_Concurrent_Type (Scope (Ent))); - Ent := Empty; + Ent := Empty; + Ovrl_Typ := Empty; end if; + return; -- Check for components @@ -12368,9 +12445,14 @@ package body Sem_Util is while Present (Node) loop case Nkind (Node) is - when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + when N_Null_Statement | N_Call_Marker => null; + when N_Raise_xxx_Error => + if Comes_From_Source (Node) then + return False; + end if; + when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) @@ -17815,6 +17897,27 @@ package body Sem_Util is return Nkind (Spec_Decl) in N_Generic_Declaration; end Is_Generic_Declaration_Or_Body; + -------------------------- + -- Is_In_Context_Clause -- + -------------------------- + + function Is_In_Context_Clause (N : Node_Id) return Boolean is + Plist : List_Id; + Parent_Node : Node_Id; + + begin + if Is_List_Member (N) then + Plist := List_Containing (N); + Parent_Node := Parent (Plist); + + return Present (Parent_Node) + and then Nkind (Parent_Node) = N_Compilation_Unit + and then Context_Items (Parent_Node) = Plist; + end if; + + return False; + end Is_In_Context_Clause; + --------------------------- -- Is_Independent_Object -- --------------------------- @@ -18276,6 +18379,7 @@ package body Sem_Util is case Nkind (N) is when N_Indexed_Component + | N_Selected_Component | N_Slice => return @@ -18287,13 +18391,6 @@ package body Sem_Util is when N_Attribute_Reference => return Attribute_Name (N) in Name_Input | Name_Old | Name_Result; - when N_Selected_Component => - return - Is_Name_Reference (Selector_Name (N)) - and then - (Is_Name_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); - when N_Explicit_Dereference => return True; @@ -20863,6 +20960,7 @@ package body Sem_Util is or else Nam = Name_Pre or else Nam = Name_Pre_Class or else Nam = Name_Precondition + or else Nam = Name_Program_Exit or else Nam = Name_Refined_Depends or else Nam = Name_Refined_Global or else Nam = Name_Refined_Post @@ -21800,7 +21898,7 @@ package body Sem_Util is Set_Last_Assignment (Ent, Empty); end if; - if Is_Object (Ent) then + if Is_Object (Ent) and then Ekind (Ent) not in Record_Field_Kind then if not Last_Assignment_Only then Kill_Checks (Ent); Set_Current_Value (Ent, Empty); @@ -21876,20 +21974,6 @@ package body Sem_Util is end loop Scope_Loop; end Kill_Current_Values; - -------------------------- - -- Kill_Size_Check_Code -- - -------------------------- - - procedure Kill_Size_Check_Code (E : Entity_Id) is - begin - if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) - and then Present (Size_Check_Code (E)) - then - Remove (Size_Check_Code (E)); - Set_Size_Check_Code (E, Empty); - end if; - end Kill_Size_Check_Code; - -------------------- -- Known_Non_Null -- -------------------- @@ -25336,6 +25420,8 @@ package body Sem_Util is end if; if Nkind (P) = N_Selected_Component + -- and then Ekind (Entity (Selector_Name (P))) + -- in Record_Field_Kind and then Present (Entry_Formal (Entity (Selector_Name (P)))) then -- Case of a reference to an entry formal @@ -25498,16 +25584,18 @@ package body Sem_Util is if Sure and then Modification_Comes_From_Source + and then Ekind (Ent) in E_Constant | E_Variable and then Overlays_Constant (Ent) and then Address_Clause_Overlay_Warnings then declare Addr : constant Node_Id := Address_Clause (Ent); O_Ent : Entity_Id; + O_Typ : Entity_Id; Off : Boolean; begin - Find_Overlaid_Entity (Addr, O_Ent, Off); + Find_Overlaid_Entity (Addr, O_Ent, O_Typ, Off); Error_Msg_Sloc := Sloc (Addr); Error_Msg_NE @@ -26066,6 +26154,24 @@ package body Sem_Util is return Empty; end Param_Entity; + --------------------- + -- Parameter_Count -- + --------------------- + + function Parameter_Count (Subp : Entity_Id) return Nat is + Result : Nat := 0; + Param : Entity_Id; + begin + Param := First_Entity (Subp); + while Present (Param) loop + Result := Result + 1; + + Param := Next_Entity (Param); + end loop; + + return Result; + end Parameter_Count; + ---------------------- -- Policy_In_Effect -- ---------------------- @@ -28409,12 +28515,6 @@ package body Sem_Util is return False; end if; - if Ekind (Entity (Selector_Name (N))) not in - E_Component | E_Discriminant - then - return False; - end if; - declare Comp : constant Entity_Id := Original_Record_Component (Entity (Selector_Name (N))); @@ -28937,9 +29037,10 @@ package body Sem_Util is ------------------------------ function Ultimate_Overlaid_Entity (E : Entity_Id) return Entity_Id is - Address : Node_Id; - Alias : Entity_Id := E; - Offset : Boolean; + Address : Node_Id; + Alias : Entity_Id := E; + Offset : Boolean; + Ovrl_Typ : Entity_Id; begin -- Currently this routine is only called for stand-alone objects that @@ -28951,7 +29052,7 @@ package body Sem_Util is loop Address := Address_Clause (Alias); if Present (Address) then - Find_Overlaid_Entity (Address, Alias, Offset); + Find_Overlaid_Entity (Address, Alias, Ovrl_Typ, Offset); if Present (Alias) then null; else |