X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_util.adb;h=3072f6a3522ff7b154f468e140feec0344255fab;hb=59e6b23c684bd7b2024faef3ac1b29279bdf2db2;hp=59d86593927d2a31e06336b5e4ca319cc95d6ef2;hpb=e280f98126fb6f0df2d7d980615b97bc4d540e5e;p=gcc.git diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 59d86593927..3072f6a3522 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -31,7 +31,6 @@ with Errout; use Errout; with Elists; use Elists; with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; -with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; @@ -141,10 +140,6 @@ package body Sem_Util is -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. - procedure Mark_Non_ALFA_Subprogram_Unconditional; - -- Perform the action for Mark_Non_ALFA_Subprogram_Body, which allows the - -- latter to be small and inlined. - ------------------------------ -- Abstract_Interface_List -- ------------------------------ @@ -505,9 +500,9 @@ package body Sem_Util is P : constant Node_Id := Prefix (N); D : Elmt_Id; Id : Node_Id; - Indx_Type : Entity_Id; + Index_Typ : Entity_Id; - Deaccessed_T : Entity_Id; + Desig_Typ : Entity_Id; -- This is either a copy of T, or if T is an access type, then it is -- the directly designated type of this access type. @@ -533,7 +528,7 @@ package body Sem_Util is Old_Lo : Node_Id; begin - Indx := First_Index (Deaccessed_T); + Indx := First_Index (Desig_Typ); while Present (Indx) loop Old_Lo := Type_Low_Bound (Etype (Indx)); Old_Hi := Type_High_Bound (Etype (Indx)); @@ -584,7 +579,7 @@ package body Sem_Util is D_Val : Node_Id; begin - D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then D_Val := Make_Selected_Component (Loc, @@ -636,19 +631,19 @@ package body Sem_Util is end if; if Ekind (T) = E_Access_Subtype then - Deaccessed_T := Designated_Type (T); + Desig_Typ := Designated_Type (T); else - Deaccessed_T := T; + Desig_Typ := T; end if; - if Ekind (Deaccessed_T) = E_Array_Subtype then - Id := First_Index (Deaccessed_T); + if Ekind (Desig_Typ) = E_Array_Subtype then + Id := First_Index (Desig_Typ); while Present (Id) loop - Indx_Type := Underlying_Type (Etype (Id)); + Index_Typ := Underlying_Type (Etype (Id)); - if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) + if Denotes_Discriminant (Type_Low_Bound (Index_Typ)) or else - Denotes_Discriminant (Type_High_Bound (Indx_Type)) + Denotes_Discriminant (Type_High_Bound (Index_Typ)) then Remove_Side_Effects (P); return @@ -659,11 +654,17 @@ package body Sem_Util is Next_Index (Id); end loop; - elsif Is_Composite_Type (Deaccessed_T) - and then Has_Discriminants (Deaccessed_T) - and then not Has_Unknown_Discriminants (Deaccessed_T) + elsif Is_Composite_Type (Desig_Typ) + and then Has_Discriminants (Desig_Typ) + and then not Has_Unknown_Discriminants (Desig_Typ) then - D := First_Elmt (Discriminant_Constraint (Deaccessed_T)); + if Is_Private_Type (Desig_Typ) + and then No (Discriminant_Constraint (Desig_Typ)) + then + Desig_Typ := Full_View (Desig_Typ); + end if; + + D := First_Elmt (Discriminant_Constraint (Desig_Typ)); while Present (D) loop if Denotes_Discriminant (Node (D)) then Remove_Side_Effects (P); @@ -948,19 +949,17 @@ package body Sem_Util is Name_Buffer (Name_Len + 2) := 'E'; Name_Len := Name_Len + 2; - -- Create elaboration flag + -- Create elaboration counter - Elab_Ent := - Make_Defining_Identifier (Loc, Chars => Name_Find); + Elab_Ent := Make_Defining_Identifier (Loc, Chars => Name_Find); Set_Elaboration_Entity (Spec_Id, Elab_Ent); Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Elab_Ent, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => - New_Occurrence_Of (Standard_False, Loc)); + Make_Object_Declaration (Loc, + Defining_Identifier => Elab_Ent, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loc), + Expression => Make_Integer_Literal (Loc, Uint_0)); Push_Scope (Standard_Standard); Add_Global_Declaration (Decl); @@ -1105,6 +1104,43 @@ package body Sem_Util is end if; end Cannot_Raise_Constraint_Error; + -------------------------------- + -- Check_Implicit_Dereference -- + -------------------------------- + + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) + is + Disc : Entity_Id; + Desig : Entity_Id; + + begin + if Ada_Version < Ada_2012 + or else not Has_Implicit_Dereference (Base_Type (Typ)) + then + return; + + elsif not Comes_From_Source (Nam) then + return; + + elsif Is_Entity_Name (Nam) + and then Is_Type (Entity (Nam)) + then + null; + + else + Disc := First_Discriminant (Typ); + while Present (Disc) loop + if Has_Implicit_Dereference (Disc) then + Desig := Designated_Type (Etype (Disc)); + Add_One_Interp (Nam, Disc, Desig); + exit; + end if; + + Next_Discriminant (Disc); + end loop; + end if; + end Check_Implicit_Dereference; + --------------------------------------- -- Check_Later_Vs_Basic_Declarations -- --------------------------------------- @@ -1324,7 +1360,7 @@ package body Sem_Util is return; end if; - -- Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested + -- Ada 2012 AI05-0144-2: Dangerous order dependence. Actuals in nested -- calls within a construct have been collected. If one of them is -- writable and overlaps with another one, evaluation of the enclosing -- construct is nondeterministic. This is illegal in Ada 2012, but is @@ -2315,47 +2351,6 @@ package body Sem_Util is end if; end Current_Subprogram; - ------------------------------ - -- Mark_Non_ALFA_Subprogram -- - ------------------------------ - - procedure Mark_Non_ALFA_Subprogram is - begin - -- Isolate marking of the current subprogram body so that the body of - -- Mark_Non_ALFA_Subprogram is small and inlined. - - if ALFA_Mode then - Mark_Non_ALFA_Subprogram_Unconditional; - end if; - end Mark_Non_ALFA_Subprogram; - - -------------------------------------------- - -- Mark_Non_ALFA_Subprogram_Unconditional -- - -------------------------------------------- - - procedure Mark_Non_ALFA_Subprogram_Unconditional is - Cur_Subp : constant Entity_Id := Current_Subprogram; - - begin - if Present (Cur_Subp) - and then (Is_Subprogram (Cur_Subp) - or else Is_Generic_Subprogram (Cur_Subp)) - then - -- If the non-ALFA construct is in a precondition or postcondition, - -- then mark the subprogram as not in ALFA. Otherwise, mark the - -- subprogram body as not in ALFA. - - -- This comment just says what is done, but not why ??? and it - -- just repeats what is in the spec ??? - - if In_Pre_Post_Expression then - Set_Is_In_ALFA (Cur_Subp, False); - else - Set_Body_Is_In_ALFA (Cur_Subp, False); - end if; - end if; - end Mark_Non_ALFA_Subprogram_Unconditional; - --------------------- -- Defining_Entity -- --------------------- @@ -3114,12 +3109,6 @@ package body Sem_Util is then null; - -- A controller component for a type extension overrides the - -- inherited component. - - elsif Chars (E) = Name_uController then - null; - -- Case of an implicit operation or derived literal. The new entity -- hides the implicit one, which is removed from all visibility, -- i.e. the entity list of its scope, and homonym chain of its name. @@ -3898,7 +3887,6 @@ package body Sem_Util is begin if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent - and then Chars (Comp) /= Name_uController then Append_Elmt (Comp, Into); end if; @@ -4180,6 +4168,15 @@ package body Sem_Util is end if; end Get_Actual_Subtype_If_Available; + ------------------------ + -- Get_Body_From_Stub -- + ------------------------ + + function Get_Body_From_Stub (N : Node_Id) return Node_Id is + begin + return Proper_Body (Unit (Library_Unit (N))); + end Get_Body_From_Stub; + ------------------------------- -- Get_Default_External_Name -- ------------------------------- @@ -4199,6 +4196,38 @@ package body Sem_Util is Strval => String_From_Name_Buffer); end Get_Default_External_Name; + -------------------------- + -- Get_Enclosing_Object -- + -------------------------- + + function Get_Enclosing_Object (N : Node_Id) return Entity_Id is + begin + if Is_Entity_Name (N) then + return Entity (N); + else + case Nkind (N) is + when N_Indexed_Component | + N_Slice | + N_Selected_Component => + + -- If not generating code, a dereference may be left implicit. + -- In thoses cases, return Empty. + + if Is_Access_Type (Etype (Prefix (N))) then + return Empty; + else + return Get_Enclosing_Object (Prefix (N)); + end if; + + when N_Type_Conversion => + return Get_Enclosing_Object (Expression (N)); + + when others => + return Empty; + end case; + end if; + end Get_Enclosing_Object; + --------------------------- -- Get_Enum_Lit_From_Pos -- --------------------------- @@ -4239,6 +4268,28 @@ package body Sem_Util is end if; end Get_Enum_Lit_From_Pos; + --------------------------------------- + -- Get_Ensures_From_Test_Case_Pragma -- + --------------------------------------- + + function Get_Ensures_From_Test_Case_Pragma (N : Node_Id) return Node_Id is + Args : constant List_Id := Pragma_Argument_Associations (N); + Res : Node_Id; + + begin + if List_Length (Args) = 4 then + Res := Pick (Args, 4); + + else + Res := Pick (Args, 3); + if Chars (Res) /= Name_Ensures then + Res := Empty; + end if; + end if; + + return Res; + end Get_Ensures_From_Test_Case_Pragma; + ------------------------ -- Get_Generic_Entity -- ------------------------ @@ -4325,6 +4376,17 @@ package body Sem_Util is return Entity_Id (Get_Name_Table_Info (Id)); end Get_Name_Entity_Id; + ------------------------------------ + -- Get_Name_From_Test_Case_Pragma -- + ------------------------------------ + + function Get_Name_From_Test_Case_Pragma (N : Node_Id) return String_Id is + Arg : constant Node_Id := + Get_Pragma_Arg (First (Pragma_Argument_Associations (N))); + begin + return Strval (Expr_Value_S (Arg)); + end Get_Name_From_Test_Case_Pragma; + ------------------- -- Get_Pragma_Id -- ------------------- @@ -4368,6 +4430,23 @@ package body Sem_Util is return R; end Get_Renamed_Entity; + ---------------------------------------- + -- Get_Requires_From_Test_Case_Pragma -- + ---------------------------------------- + + function Get_Requires_From_Test_Case_Pragma (N : Node_Id) return Node_Id is + Args : constant List_Id := Pragma_Argument_Associations (N); + Res : Node_Id; + + begin + Res := Pick (Args, 3); + if Chars (Res) /= Name_Requires then + Res := Empty; + end if; + + return Res; + end Get_Requires_From_Test_Case_Pragma; + ------------------------- -- Get_Subprogram_Body -- ------------------------- @@ -5568,7 +5647,7 @@ package body Sem_Util is return False; end if; - -- First treat specially string literals, as the lower bound and length + -- First treat string literals specially, as the lower bound and length -- of string literals are not stored like those of arrays. -- A string literal always has static bounds @@ -5597,8 +5676,9 @@ package body Sem_Util is return False; end if; - if Is_OK_Static_Expression (Low) - and then Is_OK_Static_Expression (High) + if Is_OK_Static_Expression (Low) + and then + Is_OK_Static_Expression (High) then null; else @@ -5970,6 +6050,121 @@ package body Sem_Util is and then not In_Private_Part (Scope_Id); end In_Visible_Part; + -------------------------------- + -- Incomplete_Or_Private_View -- + -------------------------------- + + function Incomplete_Or_Private_View (Typ : Entity_Id) return Entity_Id is + function Inspect_Decls + (Decls : List_Id; + Taft : Boolean := False) return Entity_Id; + -- Check whether a declarative region contains the incomplete or private + -- view of Typ. + + ------------------- + -- Inspect_Decls -- + ------------------- + + function Inspect_Decls + (Decls : List_Id; + Taft : Boolean := False) return Entity_Id + is + Decl : Node_Id; + Match : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + Match := Empty; + + if Taft then + if Nkind (Decl) = N_Incomplete_Type_Declaration then + Match := Defining_Identifier (Decl); + end if; + + else + if Nkind_In (Decl, N_Private_Extension_Declaration, + N_Private_Type_Declaration) + then + Match := Defining_Identifier (Decl); + end if; + end if; + + if Present (Match) + and then Present (Full_View (Match)) + and then Full_View (Match) = Typ + then + return Match; + end if; + + Next (Decl); + end loop; + + return Empty; + end Inspect_Decls; + + -- Local variables + + Prev : Entity_Id; + + -- Start of processing for Incomplete_Or_Partial_View + + begin + -- Incomplete type case + + Prev := Current_Entity_In_Scope (Typ); + + if Present (Prev) + and then Is_Incomplete_Type (Prev) + and then Present (Full_View (Prev)) + and then Full_View (Prev) = Typ + then + return Prev; + end if; + + -- Private or Taft amendment type case + + declare + Pkg : constant Entity_Id := Scope (Typ); + Pkg_Decl : Node_Id := Pkg; + + begin + if Ekind (Pkg) = E_Package then + while Nkind (Pkg_Decl) /= N_Package_Specification loop + Pkg_Decl := Parent (Pkg_Decl); + end loop; + + -- It is knows 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. + + if Has_Private_Declaration (Typ) then + Prev := Inspect_Decls (Visible_Declarations (Pkg_Decl)); + + -- Exchanged view case, look in the private declarations + + if No (Prev) then + Prev := Inspect_Decls (Private_Declarations (Pkg_Decl)); + end if; + + return Prev; + + -- Otherwise if this is the package body, then Typ is a potential + -- Taft amendment type. The incomplete view should be located in + -- the private declarations of the enclosing scope. + + elsif In_Package_Body (Pkg) then + return Inspect_Decls (Private_Declarations (Pkg_Decl), True); + end if; + end if; + end; + + -- The type has no incomplete or private view + + return Empty; + end Incomplete_Or_Private_View; + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- @@ -6294,23 +6489,6 @@ package body Sem_Util is end if; end Is_Atomic_Object; - ------------------------- - -- Is_Coextension_Root -- - ------------------------- - - function Is_Coextension_Root (N : Node_Id) return Boolean is - begin - return - Nkind (N) = N_Allocator - and then Present (Coextensions (N)) - - -- Anonymous access discriminants carry a list of all nested - -- controlled coextensions. - - and then not Is_Dynamic_Coextension (N) - and then not Is_Static_Coextension (N); - end Is_Coextension_Root; - ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- @@ -6819,10 +6997,7 @@ package body Sem_Util is begin Ent := First_Entity (Typ); while Present (Ent) loop - if Chars (Ent) = Name_uController then - null; - - elsif Ekind (Ent) = E_Component + if Ekind (Ent) = E_Component and then (No (Parent (Ent)) or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) @@ -7418,9 +7593,9 @@ package body Sem_Util is begin -- Verify that prefix is analyzed and has the proper form. Note that - -- the attributes Elab_Spec, Elab_Body, and UET_Address, which also - -- produce the address of an entity, do not analyze their prefix - -- because they denote entities that are not necessarily visible. + -- the attributes Elab_Spec, Elab_Body, Elab_Subp_Body and UET_Address, + -- which also produce the address of an entity, do not analyze their + -- prefix because they denote entities that are not necessarily visible. -- Neither of them can apply to a protected type. return Ada_Version >= Ada_2005 @@ -7773,6 +7948,22 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; + -------------------------------------------------- + -- Is_Subprogram_Stub_Without_Prior_Declaration -- + -------------------------------------------------- + + function Is_Subprogram_Stub_Without_Prior_Declaration + (N : Node_Id) return Boolean + is + begin + -- A subprogram stub without prior declaration serves as declaration for + -- the actual subprogram body. As such, it has an attached defining + -- entity of E_[Generic_]Function or E_[Generic_]Procedure. + + return Nkind (N) = N_Subprogram_Body_Stub + and then Ekind (Defining_Entity (N)) /= E_Subprogram_Body; + end Is_Subprogram_Stub_Without_Prior_Declaration; + --------------------------------- -- Is_Synchronized_Tagged_Type -- --------------------------------- @@ -10654,8 +10845,9 @@ package body Sem_Util is elsif Is_Record_Type (Btype) then Component := First_Entity (Btype); - while Present (Component) loop - + while Present (Component) + and then Comes_From_Source (Component) + loop -- Skip anonymous types generated by constrained components if not Is_Type (Component) then @@ -10892,7 +11084,7 @@ package body Sem_Util is -- subprogram bodies. Detect those cases by testing whether -- Process_End_Label was called for a body (Typ = 't') or a package. - if (SPARK_Mode or else Restriction_Check_Required (SPARK)) + if Restriction_Check_Required (SPARK) and then (Typ = 't' or else Ekind (Ent) = E_Package) then Error_Msg_Node_1 := Endl; @@ -11510,10 +11702,10 @@ package body Sem_Util is -- Set_Current_Entity -- ------------------------ - -- The given entity is to be set as the currently visible definition - -- of its associated name (i.e. the Node_Id associated with its name). - -- All we have to do is to get the name from the identifier, and - -- then set the associated Node_Id to point to the given entity. + -- The given entity is to be set as the currently visible definition of its + -- associated name (i.e. the Node_Id associated with its name). All we have + -- to do is to get the name from the identifier, and then set the + -- associated Node_Id to point to the given entity. procedure Set_Current_Entity (E : Entity_Id) is begin @@ -12099,6 +12291,135 @@ package body Sem_Util is return Scope_Depth (Enclosing_Dynamic_Scope (Btyp)); end Type_Access_Level; + ------------------------------------ + -- Type_Without_Stream_Operation -- + ------------------------------------ + + function Type_Without_Stream_Operation + (T : Entity_Id; + Op : TSS_Name_Type := TSS_Null) return Entity_Id + is + BT : constant Entity_Id := Base_Type (T); + Op_Missing : Boolean; + + begin + if not Restriction_Active (No_Default_Stream_Attributes) then + return Empty; + end if; + + if Is_Elementary_Type (T) then + if Op = TSS_Null then + Op_Missing := + No (TSS (BT, TSS_Stream_Read)) + or else No (TSS (BT, TSS_Stream_Write)); + + else + Op_Missing := No (TSS (BT, Op)); + end if; + + if Op_Missing then + return T; + else + return Empty; + end if; + + elsif Is_Array_Type (T) then + return Type_Without_Stream_Operation (Component_Type (T), Op); + + elsif Is_Record_Type (T) then + declare + Comp : Entity_Id; + C_Typ : Entity_Id; + + begin + Comp := First_Component (T); + while Present (Comp) loop + C_Typ := Type_Without_Stream_Operation (Etype (Comp), Op); + + if Present (C_Typ) then + return C_Typ; + end if; + + Next_Component (Comp); + end loop; + + return Empty; + end; + + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + then + return Type_Without_Stream_Operation (Full_View (T), Op); + else + return Empty; + end if; + end Type_Without_Stream_Operation; + + ---------------------------- + -- Unique_Defining_Entity -- + ---------------------------- + + function Unique_Defining_Entity (N : Node_Id) return Entity_Id is + begin + case Nkind (N) is + when N_Package_Body => + return Corresponding_Spec (N); + + when N_Subprogram_Body => + if Acts_As_Spec (N) then + return Defining_Entity (N); + else + return Corresponding_Spec (N); + end if; + + when others => + return Defining_Entity (N); + end case; + end Unique_Defining_Entity; + + ----------------- + -- Unique_Name -- + ----------------- + + function Unique_Name (E : Entity_Id) return String is + + function Get_Scoped_Name (E : Entity_Id) return String; + -- Return the name of E prefixed by all the names of the scopes to which + -- E belongs, except for Standard. + + --------------------- + -- Get_Scoped_Name -- + --------------------- + + function Get_Scoped_Name (E : Entity_Id) return String is + Name : constant String := Get_Name_String (Chars (E)); + begin + if Has_Fully_Qualified_Name (E) + or else Scope (E) = Standard_Standard + then + return Name; + else + return Get_Scoped_Name (Scope (E)) & "__" & Name; + end if; + end Get_Scoped_Name; + + -- Start of processing for Unique_Name + + begin + if E = Standard_Standard then + return Get_Name_String (Name_Standard); + + elsif Scope (E) = Standard_Standard + and then not (Ekind (E) = E_Package or else Is_Subprogram (E)) + then + return Get_Name_String (Name_Standard) & "__" & + Get_Name_String (Chars (E)); + + else + return Get_Scoped_Name (E); + end if; + end Unique_Name; + -------------------------- -- Unit_Declaration_Node -- -------------------------- @@ -12209,7 +12530,7 @@ package body Sem_Util is -- Start of processing for Unit_Is_Visible begin - -- The currrent unit is directly visible. + -- The currrent unit is directly visible if Curr = U then return True; @@ -12217,7 +12538,7 @@ package body Sem_Util is elsif Unit_In_Context (Curr) then return True; - -- If the current unit is a body, check the context of the spec. + -- If the current unit is a body, check the context of the spec elsif Nkind (Unit (Curr)) = N_Package_Body or else @@ -12229,7 +12550,7 @@ package body Sem_Util is end if; end if; - -- If the spec is a child unit, examine the parents. + -- If the spec is a child unit, examine the parents if Is_Child_Unit (Curr_Entity) then if Nkind (Unit (Curr)) in N_Unit_Body then @@ -12371,6 +12692,10 @@ package body Sem_Util is Found_Type : constant Entity_Id := First_Subtype (Etype (Expr)); Expec_Type : constant Entity_Id := First_Subtype (Expected_Type); + Matching_Field : Entity_Id; + -- Entity to give a more precise suggestion on how to write a one- + -- element positional aggregate. + function Has_One_Matching_Field return Boolean; -- Determines if Expec_Type is a record type with a single component or -- discriminant whose type matches the found type or is one dimensional @@ -12384,11 +12709,27 @@ package body Sem_Util is E : Entity_Id; begin + Matching_Field := Empty; + if Is_Array_Type (Expec_Type) and then Number_Dimensions (Expec_Type) = 1 and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) then + -- Use type name if available. This excludes multidimensional + -- arrays and anonymous arrays. + + if Comes_From_Source (Expec_Type) then + Matching_Field := Expec_Type; + + -- For an assignment, use name of target + + elsif Nkind (Parent (Expr)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (Expr))) + then + Matching_Field := Entity (Name (Parent (Expr))); + end if; + return True; elsif not Is_Record_Type (Expec_Type) then @@ -12419,6 +12760,7 @@ package body Sem_Util is return False; else + Matching_Field := E; return True; end if; end if; @@ -12467,6 +12809,16 @@ package body Sem_Util is and then Has_One_Matching_Field then Error_Msg_N ("positional aggregate cannot have one component", Expr); + if Present (Matching_Field) then + if Is_Array_Type (Expec_Type) then + Error_Msg_NE + ("\write instead `&''First ='> ...`", Expr, Matching_Field); + + else + Error_Msg_NE + ("\write instead `& ='> ...`", Expr, Matching_Field); + end if; + end if; -- Another special check, if we are looking for a pool-specific access -- type and we found an E_Access_Attribute_Type, then we have the case