diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 170 |
1 files changed, 118 insertions, 52 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a8984c8..843bfb4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6332,6 +6332,26 @@ package body Sem_Util is end Conditional_Delay; -------------------------------------- + -- Direct_Attribute_Definition_Name -- + -------------------------------------- + + function Direct_Attribute_Definition_Name + (Prefix : Entity_Id; Att_Name : Name_Id) return Name_Id is + begin + if Nkind (Prefix) = N_Attribute_Reference then + Error_Msg_N ("attribute streams not supported in " + & "direct attribute definitions", + Prefix); + end if; + + pragma Assert (Is_Attribute_Name (Att_Name)); + return New_External_Name + (Related_Id => Chars (Prefix), + Suffix => "_" & Get_Name_String (Att_Name) & "_Att", + Prefix => 'D'); + end Direct_Attribute_Definition_Name; + + -------------------------------------- -- Copy_Assertion_Policy_Attributes -- -------------------------------------- @@ -6832,30 +6852,6 @@ 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 -- --------------------- @@ -10403,6 +10399,7 @@ package body Sem_Util is Func : Entity_Id; First_Op : Entity_Id; Cursor : Entity_Id; + Specific_Type : Entity_Id := Typ; begin -- If error already detected, return @@ -10411,6 +10408,10 @@ package body Sem_Util is return Any_Type; end if; + if Is_Class_Wide_Type (Specific_Type) then + Specific_Type := Etype (Typ); + end if; + -- The cursor type for an Iterable aspect is the return type of a -- non-overloaded First primitive operation. Locate association for -- First. @@ -10441,12 +10442,13 @@ package body Sem_Util is -- is created for it, check that the base type of the first formal -- of First matches the base type of the domain. - Func := First_Entity (Scope (Typ)); + Func := First_Entity (Scope (Specific_Type)); while Present (Func) loop if Chars (Func) = Chars (First_Op) and then Ekind (Func) = E_Function and then Present (First_Formal (Func)) - and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ) + and then Base_Type (Etype (First_Formal (Func))) + = Base_Type (Specific_Type) and then No (Next_Formal (First_Formal (Func))) then if Cursor /= Any_Type then @@ -11850,6 +11852,35 @@ package body Sem_Util is (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; + ----------------------------- + -- Has_Default_Constructor -- + ----------------------------- + + function Has_Default_Constructor (Typ : Entity_Id) return Boolean is + Cursor : Entity_Id; + begin + pragma Assert (Is_Type (Typ)); + if not Needs_Construction (Typ) then + return False; + end if; + + -- Iterate through all homonyms to find the default constructor + + Cursor := Get_Name_Entity_Id + (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + while Present (Cursor) loop + if Is_Constructor (Cursor) + and then No (Next_Formal (First_Formal (Cursor))) + then + return True; + end if; + + Cursor := Homonym (Cursor); + end loop; + + return False; + end Has_Default_Constructor; + ------------------- -- Has_Denormals -- ------------------- @@ -14889,7 +14920,9 @@ package body Sem_Util is -- Incomplete_Or_Partial_View -- -------------------------------- - function Incomplete_Or_Partial_View (Id : Entity_Id) return Entity_Id is + function Incomplete_Or_Partial_View + (Id : Entity_Id; Partial_Only : Boolean := False) return Entity_Id + is S : constant Entity_Id := Scope (Id); function Inspect_Decls @@ -14972,6 +15005,7 @@ package body Sem_Util is and then (Is_Incomplete_Type (Prev) or else Ekind (Prev) = E_Constant) and then Present (Full_View (Prev)) and then Full_View (Prev) = Id + and then not Partial_Only then return Prev; end if; @@ -14983,7 +15017,7 @@ package body Sem_Util is Pkg_Decl : constant Node_Id := Package_Specification (S); begin - -- It is knows that Typ has a private view, look for it in the + -- It is known that Typ has a private view, look for it in the -- visible declarations of the enclosing scope. A special case -- of this is when the two views have been exchanged - the full -- appears earlier than the private. @@ -15003,7 +15037,7 @@ package body Sem_Util is -- Taft amendment type. The incomplete view should be located in -- the private declarations of the enclosing scope. - elsif In_Package_Body (S) then + elsif In_Package_Body (S) and then not Partial_Only then return Inspect_Decls (Private_Declarations (Pkg_Decl), True); end if; end; @@ -16120,6 +16154,12 @@ package body Sem_Util is (Nkind (Parent (Obj)) = N_Object_Renaming_Declaration and then Is_Return_Object (Defining_Entity (Parent (Obj)))); + -- RM 4.1.5(6/3): A generalized reference denotes a view equivalent to + -- that of a dereference of the reference discriminant of the object. + + elsif Nkind (Obj) = N_Function_Call then + return Has_Implicit_Dereference (Etype (Obj)); + elsif Nkind (Obj) = N_Slice then -- A slice of a bit-packed array is not considered aliased even -- for an extended access type because even extended access types @@ -16249,6 +16289,17 @@ package body Sem_Util is and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; + ----------------------------------- + -- Is_Direct_Attribute_Subp_Spec -- + ----------------------------------- + + function Is_Direct_Attribute_Subp_Spec (N : Node_Id) return Boolean is + begin + return Nkind (N) in N_Subprogram_Specification + and then Nkind (Defining_Unit_Name (Original_Node (N))) + = N_Attribute_Reference; + end Is_Direct_Attribute_Subp_Spec; + ------------------------- -- Is_Attribute_Update -- ------------------------- @@ -16951,7 +17002,7 @@ package body Sem_Util is return Present (Ret_Typ) and then Is_CPP_Class (Ret_Typ) - and then Is_Constructor (Entity (Name (N))) + and then Is_CPP_Constructor (Entity (Name (N))) and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; @@ -24817,10 +24868,20 @@ package body Sem_Util is -- Scalar_Range if Is_Discrete_Type (Id) then + + -- The scalar range of the source entity had a parent, so the + -- scalar range of the newly created entity should also have a + -- parent, so that the AST structure is the same. + + pragma Assert (Present (Parent (Scalar_Range (Id)))); + Set_Scalar_Range (Id, Node_Id ( Copy_Field_With_Replacement (Field => Union_Id (Scalar_Range (Id)), Semantic => True))); + + pragma Assert (No (Parent (Scalar_Range (Id)))); + Set_Parent (Scalar_Range (Id), Id); end if; -- Scope @@ -26669,24 +26730,6 @@ 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 -- ---------------------- @@ -27097,6 +27140,11 @@ package body Sem_Util is -- the case where Ent is a child unit. This procedure generates an -- appropriate cross-reference entry. E is the corresponding entity. + procedure Get_Attribute_Reference_Name_String (N : Node_Id); + -- This procedure append to the Global_Name_Buffer the decoded string + -- name of the attribute reference N, including apostrophes and multiple + -- prefixes. + ------------------------- -- Generate_Parent_Ref -- ------------------------- @@ -27118,6 +27166,21 @@ package body Sem_Util is end if; end Generate_Parent_Ref; + ----------------------------------------- + -- Get_Attribute_Reference_Name_String -- + ----------------------------------------- + + procedure Get_Attribute_Reference_Name_String (N : Node_Id) is + begin + if Nkind (N) /= N_Attribute_Reference then + Get_Decoded_Name_String (Chars (N)); + else + Get_Attribute_Reference_Name_String (Prefix (N)); + Append (Global_Name_Buffer, '''); + Get_Decoded_Name_String (Attribute_Name (N)); + end if; + end Get_Attribute_Reference_Name_String; + -- Start of processing for Process_End_Label begin @@ -27198,9 +27261,12 @@ package body Sem_Util is -- If the end label is not for the given entity, then either we have -- some previous error, or this is a generic instantiation for which -- we do not need to make a cross-reference in this case anyway. In - -- either case we simply ignore the call. + -- either case we simply ignore the call. Matching label for direct + -- attribute definitions are checked elsewhere. - if Chars (Ent) /= Chars (Endl) then + if Nkind (Endl) /= N_Attribute_Reference + and then Chars (Ent) /= Chars (Endl) + then return; end if; @@ -27227,7 +27293,7 @@ package body Sem_Util is -- mean the semicolon immediately following the label). This is -- done for the sake of the 'e' or 't' entry generated below. - Get_Decoded_Name_String (Chars (Endl)); + Get_Attribute_Reference_Name_String (Endl); Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len)); end if; @@ -30672,7 +30738,7 @@ package body Sem_Util is -- of the same modular type, and (M1 and M2) = 0 was intended. if Expec_Type = Standard_Boolean - and then Is_Modular_Integer_Type (Found_Type) + and then Has_Modular_Operations (Found_Type) and then Nkind (Parent (Expr)) in N_Op_And | N_Op_Or | N_Op_Xor and then Nkind (Right_Opnd (Parent (Expr))) in N_Op_Compare then |