* sinfo.adb, sinfo.ads, sem_prag.adb, sem_ch12.adb (Pragma_Enabled):
This flag of N_Pragma nodes is not used, remove it as well as all of
the associated circuitry.
2011-08-04 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_DT): Switch -gnatdQ disables the generation of the
runtime check on duplicated externa tags
* debug.adb Document switch -gnatdQ.
2011-08-04 Gary Dismukes <dismukes@adacore.com>
* a-fihema.ads: Minor typo fix.
2011-08-04 Yannick Moy <moy@adacore.com>
* sem_ch10.adb: Minor comment update.
2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb: Update the node field usage to reflect the renaming of
Return_Flag to Return_ Flag_Or_Transient_Decl.
(Return_Flag): Renamed to Return_Flag_Or_Transient_Decl.
(Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl.
(Write_Field15_Name): Change Return_Flag to
Return_Flag_Or_Transient_Decl.
* einfo.ads: Rename node field Return_Flag to
Return_Flag_Or_Transient_Decl. Update the associated comment and all
occurrences in entities.
(Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. Update
associated Inline pragma.
(Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. Update
associated Inline pragma.
* exp_ch4.ads, exp_ch4.adb (Expand_N_Expression_With_Actions): New
routine.
* exp_ch6.adb (Expand_N_Extended_Return_Statement): Update the calls to
Return_Flag and Set_Return_Flag.
* exp_ch7.adb (Process_Declarations): Add code to recognize hook
objects generated for controlled transients declared inside an
Exception_With_Actions. Update the calls to Return_Flag.
(Process_Object_Declaration): Add code to add a null guard for hook
objects generated for controlled transients declared inside an
Exception_With_Actions. Update related comment.
* exp_util.adb (Has_Controlled_Objects): Add code to recognize hook
objects generated for controlled transients declared inside an
Exception_With_Actions. Update the calls to Return_Flag.
* expander.adb (Expand): Add new case for N_Expression_With_Actions.
2011-08-04 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb:(Wrong_Type): Improve error message on a one-element
positional aggregate.
2011-08-04 Vincent Celier <celier@adacore.com>
* par_sco.adb (Process_Decisions.Output_Header): Check and record pragma
SLOC only for pragmas.
2011-08-04 Emmanuel Briot <briot@adacore.com>
* projects.texi: Minor typo fix.
2011-08-04 Emmanuel Briot <briot@adacore.com>
* prj-nmsc.adb (Check_File): Minor change to traces, to help debugging
on case-sensitive file systems.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@177349
138bc75d-0d04-0410-961f-
82ee72b054a4
2011-08-04 Thomas Quinot <quinot@adacore.com>
+ * sinfo.adb, sinfo.ads, sem_prag.adb, sem_ch12.adb (Pragma_Enabled):
+ This flag of N_Pragma nodes is not used, remove it as well as all of
+ the associated circuitry.
+
+2011-08-04 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_DT): Switch -gnatdQ disables the generation of the
+ runtime check on duplicated externa tags
+ * debug.adb Document switch -gnatdQ.
+
+2011-08-04 Gary Dismukes <dismukes@adacore.com>
+
+ * a-fihema.ads: Minor typo fix.
+
+2011-08-04 Yannick Moy <moy@adacore.com>
+
+ * sem_ch10.adb: Minor comment update.
+
+2011-08-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb: Update the node field usage to reflect the renaming of
+ Return_Flag to Return_ Flag_Or_Transient_Decl.
+ (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl.
+ (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl.
+ (Write_Field15_Name): Change Return_Flag to
+ Return_Flag_Or_Transient_Decl.
+ * einfo.ads: Rename node field Return_Flag to
+ Return_Flag_Or_Transient_Decl. Update the associated comment and all
+ occurrences in entities.
+ (Return_Flag): Renamed to Return_Flag_Or_Transient_Decl. Update
+ associated Inline pragma.
+ (Set_Return_Flag): Renamed to Set_Return_Flag_Or_Transient_Decl. Update
+ associated Inline pragma.
+ * exp_ch4.ads, exp_ch4.adb (Expand_N_Expression_With_Actions): New
+ routine.
+ * exp_ch6.adb (Expand_N_Extended_Return_Statement): Update the calls to
+ Return_Flag and Set_Return_Flag.
+ * exp_ch7.adb (Process_Declarations): Add code to recognize hook
+ objects generated for controlled transients declared inside an
+ Exception_With_Actions. Update the calls to Return_Flag.
+ (Process_Object_Declaration): Add code to add a null guard for hook
+ objects generated for controlled transients declared inside an
+ Exception_With_Actions. Update related comment.
+ * exp_util.adb (Has_Controlled_Objects): Add code to recognize hook
+ objects generated for controlled transients declared inside an
+ Exception_With_Actions. Update the calls to Return_Flag.
+ * expander.adb (Expand): Add new case for N_Expression_With_Actions.
+
+2011-08-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb:(Wrong_Type): Improve error message on a one-element
+ positional aggregate.
+
+2011-08-04 Vincent Celier <celier@adacore.com>
+
+ * par_sco.adb (Process_Decisions.Output_Header): Check and record pragma
+ SLOC only for pragmas.
+
+2011-08-04 Emmanuel Briot <briot@adacore.com>
+
+ * projects.texi: Minor typo fix.
+
+2011-08-04 Emmanuel Briot <briot@adacore.com>
+
+ * prj-nmsc.adb (Check_File): Minor change to traces, to help debugging
+ on case-sensitive file systems.
+
+2011-08-04 Thomas Quinot <quinot@adacore.com>
+
* put_scos.adb (Put_SCOs): Do not emit decision SCO for an X decision
nested in a disabled pragma.
* scos.ads, scos.adb, par_sco.ads, par_sco.adb: Record sloc of
Finalize_Address : Finalize_Address_Ptr;
-- A reference to a routine which finalizes an object denoted by its
- -- address. The collection must be homogenious since the same routine
+ -- address. The collection must be homogeneous since the same routine
-- will be invoked for every allocated object when the pool is
-- finalized.
-- dN No file name information in exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
- -- dQ
+ -- dQ Do not generate runtime check for duplicated external tag
-- dR Bypass check for correct version of s-rpc
-- dS Never convert numbers to machine numbers in Sem_Eval
-- dT Convert to machine numbers only for constant declarations
-- in preelaborable packages, but this restriction is a huge pain,
-- especially in the predefined library units.
+ -- dQ Eliminate check for duplicate external tags. This check was added
+ -- for GNAT 6.4.1, and causes some backward compatibility problems.
+ -- It is never legitimate to have duplicate external tags, so the
+ -- check is certainly valid, but this debug switch can be useful for
+ -- enabling previous behavior of ignoring this problem.
+
-- dR Bypass the check for a proper version of s-rpc being present
-- to use the -gnatz? switch. This allows debugging of the use
-- of stubs generation without needing to have GLADE (or some
-- Extra_Formal Node15
-- Lit_Indexes Node15
-- Related_Instance Node15
- -- Return_Flag Node15
+ -- Return_Flag_Or_Transient_Decl Node15
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- String_Literal_Low_Bound Node15
return Flag213 (Id);
end Requires_Overriding;
- function Return_Flag (Id : E) return N is
+ function Return_Flag_Or_Transient_Decl (Id : E) return N is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
return Node15 (Id);
- end Return_Flag;
+ end Return_Flag_Or_Transient_Decl;
function Return_Present (Id : E) return B is
begin
Set_Flag213 (Id, V);
end Set_Requires_Overriding;
- procedure Set_Return_Flag (Id : E; V : E) is
+ procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
Set_Node15 (Id, V);
- end Set_Return_Flag;
+ end Set_Return_Flag_Or_Transient_Decl;
procedure Set_Return_Present (Id : E; V : B := True) is
begin
when E_Constant |
E_Variable =>
- Write_Str ("Return_Flag");
+ Write_Str ("Return_Flag_Or_Transient_Decl");
when Decimal_Fixed_Point_Kind =>
Write_Str ("Scale_Value");
-- is True only for implicitly declare subprograms; it is not set on the
-- parent type's subprogram. See also Is_Abstract_Subprogram.
--- Return_Flag (Node15)
+-- Return_Flag_Or_Transient_Decl (Node15)
-- Applies to variables and constants. Set for objects which act as the
-- return value of an extended return statement. The node contains the
-- entity of a locally declared flag which controls the finalization of
--- the return object should the function fail.
+-- the return object should the function fail. Also set for access-to-
+-- controlled objects used to provide a hook to controlled transients
+-- declared inside an Expression_With_Actions. The node contains the
+-- object declaration of the controlled transient.
-- Return_Present (Flag54)
-- Present in function and generic function entities. Set if the
-- Full_View (Node11)
-- Esize (Uint12)
-- Alignment (Uint14)
- -- Return_Flag (Node15) (constants only)
+ -- Return_Flag_Or_Transient_Decl (Node15) (constants only)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19) (constants only)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
- -- Return_Flag (Node15) (transient object only)
+ -- Return_Flag_Or_Transient_Decl (Node15) (transient object only)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
function Renamed_Object (Id : E) return N;
function Renaming_Map (Id : E) return U;
function Requires_Overriding (Id : E) return B;
- function Return_Flag (Id : E) return E;
+ function Return_Flag_Or_Transient_Decl (Id : E) return E;
function Return_Present (Id : E) return B;
function Return_Applies_To (Id : E) return N;
function Returns_By_Ref (Id : E) return B;
procedure Set_Renamed_Object (Id : E; V : N);
procedure Set_Renaming_Map (Id : E; V : U);
procedure Set_Requires_Overriding (Id : E; V : B := True);
- procedure Set_Return_Flag (Id : E; V : E);
+ procedure Set_Return_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Return_Present (Id : E; V : B := True);
procedure Set_Return_Applies_To (Id : E; V : N);
procedure Set_Returns_By_Ref (Id : E; V : B := True);
pragma Inline (Renamed_Object);
pragma Inline (Renaming_Map);
pragma Inline (Requires_Overriding);
- pragma Inline (Return_Flag);
+ pragma Inline (Return_Flag_Or_Transient_Decl);
pragma Inline (Return_Present);
pragma Inline (Return_Applies_To);
pragma Inline (Returns_By_Ref);
pragma Inline (Set_Renamed_Object);
pragma Inline (Set_Renaming_Map);
pragma Inline (Set_Requires_Overriding);
- pragma Inline (Set_Return_Flag);
+ pragma Inline (Set_Return_Flag_Or_Transient_Decl);
pragma Inline (Set_Return_Present);
pragma Inline (Set_Return_Applies_To);
pragma Inline (Set_Returns_By_Ref);
Insert_Dereference_Action (Prefix (N));
end Expand_N_Explicit_Dereference;
+ --------------------------------------
+ -- Expand_N_Expression_With_Actions --
+ --------------------------------------
+
+ procedure Expand_N_Expression_With_Actions (N : Node_Id) is
+
+ procedure Process_Transient_Object (Decl : Node_Id);
+ -- Given the declaration of a controlled transient declared inside the
+ -- Actions list of an Expression_With_Actions, generate all necessary
+ -- types and hooks in order to properly finalize the transient. This
+ -- mechanism works in conjunction with Build_Finalizer.
+
+ ------------------------------
+ -- Process_Transient_Object --
+ ------------------------------
+
+ procedure Process_Transient_Object (Decl : Node_Id) is
+ Ins_Nod : constant Node_Id := Parent (N);
+ -- To avoid the insertion of generated code in the list of Actions,
+ -- Insert_Action must look at the parent field of the EWA.
+
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Obj_Typ : constant Entity_Id := Etype (Obj_Id);
+ Desig_Typ : Entity_Id;
+ Expr : Node_Id;
+ Ptr_Decl : Node_Id;
+ Ptr_Id : Entity_Id;
+ Temp_Decl : Node_Id;
+ Temp_Id : Node_Id;
+
+ begin
+ -- Step 1: Create the access type which provides a reference to
+ -- the transient object.
+
+ if Is_Access_Type (Obj_Typ) then
+ Desig_Typ := Directly_Designated_Type (Obj_Typ);
+ else
+ Desig_Typ := Obj_Typ;
+ end if;
+
+ -- Generate:
+ -- Ann : access [all] <Desig_Typ>;
+
+ Ptr_Id := Make_Temporary (Loc, 'A');
+
+ Ptr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present =>
+ Ekind (Obj_Typ) = E_General_Access_Type,
+ Subtype_Indication =>
+ New_Reference_To (Desig_Typ, Loc)));
+
+ Insert_Action (Ins_Nod, Ptr_Decl);
+ Analyze (Ptr_Decl);
+
+ -- Step 2: Create a temporary which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Temp : Ptr_Id := null;
+
+ Temp_Id := Make_Temporary (Loc, 'T');
+
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition => New_Reference_To (Ptr_Id, Loc));
+
+ Insert_Action (Ins_Nod, Temp_Decl);
+ Analyze (Temp_Decl);
+
+ -- Mark this temporary as created for the purposes of "exporting" the
+ -- transient declaration out of the Actions list. This signals the
+ -- machinery in Build_Finalizer to recognize this special case.
+
+ Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl);
+
+ -- Step 3: "Hook" the transient object to the temporary
+
+ if Is_Access_Type (Obj_Typ) then
+ Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
+ else
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
+
+ -- Generate:
+ -- Temp := Ptr_Id (Obj_Id);
+ -- <or>
+ -- Temp := Obj_Id'Unrestricted_Access;
+
+ Insert_After_And_Analyze (Decl,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Expr));
+ end Process_Transient_Object;
+
+ Decl : Node_Id;
+
+ -- Start of processing for Expand_N_Expression_With_Actions
+
+ begin
+ Decl := First (Actions (N));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration
+ and then Is_Finalizable_Transient (Decl, N)
+ then
+ Process_Transient_Object (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Expand_N_Expression_With_Actions;
+
-----------------
-- Expand_N_In --
-----------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
procedure Expand_N_Case_Expression (N : Node_Id);
procedure Expand_N_Conditional_Expression (N : Node_Id);
procedure Expand_N_Explicit_Dereference (N : Node_Id);
+ procedure Expand_N_Expression_With_Actions (N : Node_Id);
procedure Expand_N_In (N : Node_Id);
procedure Expand_N_Indexed_Component (N : Node_Id);
procedure Expand_N_Not_In (N : Node_Id);
-- Create a flag to track the function state
Flag_Id := Make_Temporary (Loc, 'F');
- Set_Return_Flag (Ret_Obj_Id, Flag_Id);
+ Set_Return_Flag_Or_Transient_Decl (Ret_Obj_Id, Flag_Id);
-- Insert the flag at the beginning of the function declarations,
-- generate:
and then Needs_Finalization (Etype (Ret_Obj_Id))
then
declare
- Flag_Id : constant Entity_Id := Return_Flag (Ret_Obj_Id);
-
+ Flag_Id : constant Entity_Id :=
+ Return_Flag_Or_Transient_Decl (Ret_Obj_Id);
begin
-- Generate:
-- Fnn := True;
then
Processing_Actions (Has_No_Init => True);
+ elsif Is_Access_Type (Obj_Typ)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
+ and then Is_Finalizable_Transient
+ (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ then
+ Processing_Actions (Has_No_Init => True);
+
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should
-- be treated as controlled since they require manual cleanup.
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag (Obj_Id))
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
Processing_Actions (Has_No_Init => True);
end if;
end;
end if;
- -- Return objects use a flag to aid their potential finalization
- -- then the enclosing function fails to return properly. Generate:
- --
- -- if not Flag then
- -- <object finalization statements>
- -- end if;
-
if Ekind_In (Obj_Id, E_Constant, E_Variable)
- and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag (Obj_Id))
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
- Fin_Stmts := New_List (
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- New_Reference_To (Return_Flag (Obj_Id), Loc)),
+ -- Return objects use a flag to aid their potential
+ -- finalization when the enclosing function fails to return
+ -- properly. Generate:
+ --
+ -- if not Flag then
+ -- <object finalization statements>
+ -- end if;
+
+ if Is_Return_Object (Obj_Id) then
+ Fin_Stmts := New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ New_Reference_To
+ (Return_Flag_Or_Transient_Decl (Obj_Id), Loc)),
+
+ Then_Statements => Fin_Stmts));
+
+ -- Temporaries created for the purpose of "exporting" a
+ -- controlled transient out of an Expression_With_Actions (EWA)
+ -- need guards. The following illustrates the usage of such
+ -- temporaries.
+
+ -- Access_Typ : access [all] Obj_Typ;
+ -- Temp : Access_Typ := null;
+ -- <Counter> := ...;
+
+ -- do
+ -- Ctrl_Trans : [access [all]] Obj_Typ := ...;
+ -- Temp := Access_Typ (Ctrl_Trans); -- when a pointer
+ -- <or>
+ -- Temp := Ctrl_Trans'Unchecked_Access;
+ -- in ... end;
+
+ -- The finalization machinery does not process EWA nodes as
+ -- this may lead to premature finalization of expressions. Note
+ -- that Temp is marked as being properly initialized regardless
+ -- of whether the initialization of Ctrl_Trans succeeded. Since
+ -- a failed initialization may leave Temp with a value of null,
+ -- add a guard to handle this case:
+
+ -- if Obj /= null then
+ -- <object finalization statements>
+ -- end if;
- Then_Statements => Fin_Stmts));
+ else
+ pragma Assert
+ (Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration);
+
+ Fin_Stmts := New_List (
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Reference_To (Obj_Id, Loc),
+ Right_Opnd => Make_Null (Loc)),
+
+ Then_Statements => Fin_Stmts));
+ end if;
end if;
end if;
if not No_Run_Time_Mode
and then Ada_Version >= Ada_2005
and then RTE_Available (RE_Check_TSD)
+ and then not Debug_Flag_QQ
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
then
return True;
+ elsif Is_Access_Type (Obj_Typ)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
+ and then Is_Finalizable_Transient
+ (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ then
+ return True;
+
-- Simple protected objects which use type System.Tasking.
-- Protected_Objects.Protection to manage their locks should be
-- treated as controlled since they require manual cleanup.
elsif Needs_Finalization (Obj_Typ)
and then Is_Return_Object (Obj_Id)
- and then Present (Return_Flag (Obj_Id))
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
then
return True;
end if;
when N_Explicit_Dereference =>
Expand_N_Explicit_Dereference (N);
+ when N_Expression_With_Actions =>
+ Expand_N_Expression_With_Actions (N);
+
when N_Extended_Return_Statement =>
Expand_N_Extended_Return_Statement (N);
Loc := Sloc (Parent (Parent (N)));
- -- Record sloc of pragma (pragmas don't nest)
+ if T = 'P' then
+ -- Record sloc of pragma (pragmas don't nest)
- pragma Assert (Pragma_Sloc = No_Location);
- Pragma_Sloc := Loc;
+ pragma Assert (Pragma_Sloc = No_Location);
+ Pragma_Sloc := Loc;
+ end if;
when 'X' =>
if Current_Verbosity = High then
Debug_Increase_Indent
("Checking file (rank=" & Source_Dir_Rank'Img & ")",
- Name_Id (Path));
+ Name_Id (Display_Path));
end if;
if Name_Loc = No_Name_Location then
@item @b{Library_Options}:
@cindex @code{Library_Options}
- This attribute may be used to specified additional switches (last switches)
+ This attribute may be used to specify additional switches (last switches)
when linking a shared library.
@item @b{Leading_Library_Options}:
-- If the unit is a subprogram body, then we similarly need to analyze
-- its spec. However, things are a little simpler in this case, because
- -- here, this analysis is done only for error checking and consistency
- -- purposes, so there's nothing else to be done.
+ -- here, this analysis is done mostly for error checking and consistency
+ -- purposes (but not only, e.g. there could be a contract on the spec),
+ -- so there's nothing else to be done.
elsif Nkind (Unit_Node) = N_Subprogram_Body then
if Acts_As_Spec (N) then
-- All other cases than aggregates
else
- -- For pragmas, we propagate the Enabled status for the
- -- relevant pragmas to the original generic tree. This was
- -- originally needed for SCO generation. It is no longer
- -- needed there (since we use the Sloc value in calls to
- -- Set_SCO_Pragma_Enabled), but it seems a generally good
- -- idea to have this flag set properly.
-
- if Nkind (N) = N_Pragma
- and then
- (Pragma_Name (N) = Name_Assert or else
- Pragma_Name (N) = Name_Check or else
- Pragma_Name (N) = Name_Precondition or else
- Pragma_Name (N) = Name_Postcondition)
- and then Present (Associated_Node (Pragma_Identifier (N)))
- then
- Set_Pragma_Enabled (N,
- Pragma_Enabled
- (Parent (Associated_Node (Pragma_Identifier (N)))));
- end if;
-
Save_Global_Descendant (Field1 (N));
Save_Global_Descendant (Field2 (N));
Save_Global_Descendant (Field3 (N));
-- Record if pragma is enabled
if Check_Enabled (Pname) then
- Set_Pragma_Enabled (N);
Set_SCO_Pragma_Enabled (Loc);
end if;
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
if Check_On then
- Set_Pragma_Enabled (N);
- Set_Pragma_Enabled (Original_Node (N));
Set_SCO_Pragma_Enabled (Loc);
end if;
----------------
procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
- Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
- Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
+ 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
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
return False;
else
+ Matching_Field := E;
return True;
end if;
end if;
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
return List2 (N);
end Pragma_Argument_Associations;
- function Pragma_Enabled
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- return Flag5 (N);
- end Pragma_Enabled;
-
function Pragma_Identifier
(N : Node_Id) return Node_Id is
begin
Set_List2_With_Parent (N, Val);
end Set_Pragma_Argument_Associations;
- procedure Set_Pragma_Enabled
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Pragma);
- Set_Flag5 (N, Val);
- end Set_Pragma_Enabled;
-
procedure Set_Pragma_Identifier
(N : Node_Id; Val : Node_Id) is
begin
-- package specification. This field is Empty for library bodies (the
-- parent spec in this case can be found from the corresponding spec).
- -- Pragma_Enabled (Flag5-Sem)
- -- Present in N_Pragma nodes. This flag is relevant only for pragmas
- -- Assert, Check, Precondition, and Postcondition. It is true if the
- -- check corresponding to the pragma type is enabled at the point where
- -- the pragma appears.
-
-- Present_Expr (Uint3-Sem)
-- Present in an N_Variant node. This has a meaningful value only after
-- Gigi has back annotated the tree with representation information. At
-- Pragma_Argument_Associations (List2) (set to No_List if none)
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
- -- Pragma_Enabled (Flag5-Sem)
-- From_Aspect_Specification (Flag13-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Import_Interface_Present (Flag16-Sem)
function Pragma_Argument_Associations
(N : Node_Id) return List_Id; -- List2
- function Pragma_Enabled
- (N : Node_Id) return Boolean; -- Flag5
-
function Pragma_Identifier
(N : Node_Id) return Node_Id; -- Node4
procedure Set_Pragma_Argument_Associations
(N : Node_Id; Val : List_Id); -- List2
- procedure Set_Pragma_Enabled
- (N : Node_Id; Val : Boolean := True); -- Flag5
-
procedure Set_Pragma_Identifier
(N : Node_Id; Val : Node_Id); -- Node4
pragma Inline (Parent_Spec);
pragma Inline (Position);
pragma Inline (Pragma_Argument_Associations);
- pragma Inline (Pragma_Enabled);
pragma Inline (Pragma_Identifier);
pragma Inline (Pragmas_After);
pragma Inline (Pragmas_Before);
pragma Inline (Set_Parent_Spec);
pragma Inline (Set_Position);
pragma Inline (Set_Pragma_Argument_Associations);
- pragma Inline (Set_Pragma_Enabled);
pragma Inline (Set_Pragma_Identifier);
pragma Inline (Set_Pragmas_After);
pragma Inline (Set_Pragmas_Before);
projects / platform / upstream / linaro-gcc.git / commitdiff