+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Check_Postcondition_Use_In_Inlined_Subprogram):
+ Do not warn on conditions that are not obeyed for Inline_Always
+ subprograms, when assertions are not enabled.
+
+2017-09-06 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Unique_Entity): For abstract states return their
+ non-limited view.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * sem_ch12.adb (Copy_Generic_Node): When we copy a node
+ that is a proper body corresponding to a stub, we defer the
+ adjustment of the sloc until after the correct adjustment has
+ been computed. Otherwise, Adjust_Instantiation_Sloc will ignore
+ the adjustment, because it will be outside the range in (the old,
+ incorrect) S_Adjustment.
+ * inline.adb: Use named notation for readability and uniformity.
+ * sinput-l.adb: Minor improvements to debugging output printed
+ for Debug_Flag_L.
+ * sinput-l.ads (Create_Instantiation_Source): Minor comment
+ correction.
+
+2017-09-06 Vincent Celier <celier@adacore.com>
+
+ * make.adb: Do not invoke gprbuild for -bargs -P.
+
+2017-09-06 Sylvain Dailler <dailler@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Known_Value_Or_Aggr): Adding a
+ case when Op is of kind N_Qualified_Expression. In this case,
+ the function is called recursively on the subexpression like in
+ other cases.
+ * make.adb: Minor reformatting
+
+2017-09-06 Justin Squirek <squirek@adacore.com>
+
+ * einfo.adb (Set_Linker_Section_Pragma): Modify
+ Set_Linker_Section_Pragma to be consistant with the "getter"
+ Linker_Section_Pragma.
+ * exp_ch5.adb (Expand_Formal_Container_Loop): Add proper error
+ checking for container loops so that the index cursor is not
+ directly changable by the user with the use of E_Loop_Parameter.
+ * sem_ch5.adb (Analyze_Block_Statement): Revert previous change.
+ * sem_warn.adb (Check_References): Revert previous change.
+
2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (gnat_to_gnu) <N_Selected_Component>: Try
with Opt; use Opt;
with Osint; use Osint;
with Osint.M; use Osint.M;
--- with Sdefault;
with Snames;
with Stringt;
with Switch; use Switch;
package body Clean is
Initialized : Boolean := False;
- -- Set to True by the first call to Initialize to avoid reinitialization
- -- of some packages.
+ -- Set to True by the first call to Initialize to avoid reinitialization of
+ -- some packages.
-- Suffixes of various files
function Linker_Section_Pragma (Id : E) return N is
begin
pragma Assert
- (Is_Type (Id) or else Is_Object (Id) or else Is_Subprogram (Id));
+ (Is_Object (Id) or else Is_Subprogram (Id) or else Is_Type (Id));
return Node33 (Id);
end Linker_Section_Pragma;
procedure Set_Linker_Section_Pragma (Id : E; V : N) is
begin
- pragma Assert (Is_Type (Id)
- or else Ekind_In (Id, E_Constant, E_Variable)
- or else Is_Subprogram (Id));
+ pragma Assert
+ (Is_Object (Id) or else Is_Subprogram (Id) or else Is_Type (Id));
Set_Node33 (Id, V);
end Set_Linker_Section_Pragma;
return Empty;
end Get_Attribute_Definition_Clause;
+ ---------------------------
+ -- Get_Class_Wide_Pragma --
+ ---------------------------
+
+ function Get_Class_Wide_Pragma
+ (E : Entity_Id;
+ Id : Pragma_Id) return Node_Id
+ is
+ Item : Node_Id;
+ Items : Node_Id;
+
+ begin
+ Items := Contract (E);
+
+ if No (Items) then
+ return Empty;
+ end if;
+
+ Item := Pre_Post_Conditions (Items);
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
+ and then Class_Present (Item)
+ then
+ return Item;
+ end if;
+
+ Item := Next_Pragma (Item);
+ end loop;
+
+ return Empty;
+ end Get_Class_Wide_Pragma;
+
-------------------
-- Get_Full_View --
-------------------
return Empty;
end Get_Pragma;
- --------------------------
- -- Get_Classwide_Pragma --
- --------------------------
-
- function Get_Classwide_Pragma
- (E : Entity_Id;
- Id : Pragma_Id) return Node_Id
- is
- Item : Node_Id;
- Items : Node_Id;
-
- begin
- Items := Contract (E);
- if No (Items) then
- return Empty;
- end if;
-
- Item := Pre_Post_Conditions (Items);
-
- while Present (Item) loop
- if Nkind (Item) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
- and then Class_Present (Item)
- then
- return Item;
- else
- Item := Next_Pragma (Item);
- end if;
- end loop;
-
- return Empty;
- end Get_Classwide_Pragma;
-
--------------------------------------
-- Get_Record_Representation_Clause --
--------------------------------------
-- Test_Case
-- Volatile_Function
- function Get_Classwide_Pragma
+ function Get_Class_Wide_Pragma
(E : Entity_Id;
Id : Pragma_Id) return Node_Id;
- -- Examine Rep_Item chain to locate a classwide pre- or postcondition
- -- of a primitive operation. Returns Empty if not present.
+ -- Examine Rep_Item chain to locate a classwide pre- or postcondition of a
+ -- primitive operation. Returns Empty if not present.
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
Make_Iteration_Scheme (Loc,
Condition =>
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Has_Element_Op, Loc),
+ Name =>
+ New_Occurrence_Of (Has_Element_Op, Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
New_Occurrence_Of (Cursor, Loc)))),
Container : constant Node_Id := Entity (Name (I_Spec));
Stats : constant List_Id := Statements (N);
- Advance : Node_Id;
- Blk_Nod : Node_Id;
- Init : Node_Id;
- New_Loop : Node_Id;
+ Advance : Node_Id;
+ Init_Decl : Node_Id;
+ New_Loop : Node_Id;
begin
- -- The expansion resembles the one for Ada containers, but the
- -- primitives mention the domain of iteration explicitly, and
- -- function First applied to the container yields a cursor directly.
+ -- The expansion of a formal container loop resembles the one for Ada
+ -- containers. The only difference is that the primitives mention the
+ -- domain of iteration explicitly, and function First applied to the
+ -- container yields a cursor directly.
-- Cursor : Cursor_type := First (Container);
-- while Has_Element (Cursor, Container) loop
-- end loop;
Build_Formal_Container_Iteration
- (N, Container, Cursor, Init, Advance, New_Loop);
+ (N, Container, Cursor, Init_Decl, Advance, New_Loop);
- Set_Ekind (Cursor, E_Variable);
Append_To (Stats, Advance);
- -- Build block to capture declaration of cursor entity.
+ -- Build a block to capture declaration of the cursor
- Blk_Nod :=
+ Rewrite (N,
Make_Block_Statement (Loc,
- Declarations => New_List (Init),
+ Declarations => New_List (Init_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (New_Loop)));
+ Statements => New_List (New_Loop))));
+
+ -- The loop parameter is declared by an object declaration, but within
+ -- the loop we must prevent user assignments to it, so we analyze the
+ -- declaration and reset the entity kind, before analyzing the rest of
+ -- the loop.
+
+ Analyze (Init_Decl);
+ Set_Ekind (Defining_Identifier (Init_Decl), E_Loop_Parameter);
+
+ -- The cursor was marked as a loop parameter to prevent user assignments
+ -- to it, however this renders the advancement step illegal as it is not
+ -- possible to change the value of a constant. Flag the advancement step
+ -- as a legal form of assignment to remedy this side effect.
+
+ Set_Assignment_OK (Name (Advance));
- Rewrite (N, Blk_Nod);
Analyze (N);
end Expand_Formal_Container_Loop;
-- The loop parameter is declared by an object declaration, but within
-- the loop we must prevent user assignments to it, so we analyze the
-- declaration and reset the entity kind, before analyzing the rest of
- -- the loop;
+ -- the loop.
Analyze (Elmt_Decl);
Set_Ekind (Defining_Identifier (Elmt_Decl), E_Loop_Parameter);
New_Prag : Node_Id;
begin
- A_Pre := Get_Classwide_Pragma (Par_Prim, Pragma_Precondition);
+ A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition);
+
if Present (A_Pre) then
New_Prag := New_Copy_Tree (A_Pre);
Build_Class_Wide_Expression
end if;
end if;
- A_Post := Get_Classwide_Pragma (Par_Prim, Pragma_Postcondition);
+ A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition);
if Present (A_Post) then
New_Prag := New_Copy_Tree (A_Post);
if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
Save_Env (Scope (Current_Scope), Scope (Current_Scope));
- Original_Body := Copy_Generic_Node (N, Empty, True);
+ Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
else
Original_Body := Copy_Separate_Tree (N);
end if;
Remove_Aspects_And_Pragmas (Original_Body);
- Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+ Body_To_Analyze :=
+ Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
-- Set return type of function, which is also global and does not need
-- to be resolved.
if In_Instance
and then Scope (Current_Scope) /= Standard_Standard
then
- Body_To_Inline := Copy_Generic_Node (N, Empty, True);
+ Body_To_Inline :=
+ Copy_Generic_Node (N, Empty, Instantiating => True);
else
Body_To_Inline := Copy_Separate_Tree (N);
end if;
-- parameterless subprogram, declared within the real one.
Generate_Subprogram_Body (N, Original_Body);
- Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
+ Body_To_Analyze :=
+ Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
-- Set return type of function, which is also global and does not
-- need to be resolved.
Success : Boolean;
Target : String_Access := null;
+ In_Gnatmake_Switches : Boolean := True;
+ -- Set to False after -cargs, -bargs, or -largs, to avoid detecting
+ -- -P switches that are not for gnatmake.
+
begin
Find_Program_Name;
declare
Arg : constant String := Argument (J);
begin
- if Arg'Length >= 2
+ if Arg = "-cargs" or Arg = "-bargs" or Arg = "-largs" then
+ In_Gnatmake_Switches := False;
+
+ elsif Arg = "-margs" then
+ In_Gnatmake_Switches := True;
+
+ elsif In_Gnatmake_Switches
+ and then Arg'Length >= 2
and then Arg (Arg'First .. Arg'First + 1) = "-P"
then
Call_Gprbuild := True;
(Formal, Match, Analyzed_Formal),
Assoc_List);
- -- Determine whether the actual package needs an
- -- explicit freeze node. This is only the case if
- -- the actual is declared in the same unit and has
- -- a body. Normally packages do not have explicit
- -- freeze nodes, and gigi only uses them to elaborate
- -- entities in a package body.
+ -- Determine whether the actual package needs an explicit
+ -- freeze node. This is only the case if the actual is
+ -- declared in the same unit and has a body. Normally
+ -- packages do not have explicit freeze nodes, and gigi
+ -- only uses them to elaborate entities in a package
+ -- body.
declare
Actual : constant Entity_Id := Entity (Match);
+
Needs_Freezing : Boolean;
- S : Entity_Id;
+ S : Entity_Id;
begin
if not Expander_Active
or else not Has_Completion (Actual)
or else not In_Same_Source_Unit (I_Node, Actual)
- or else (Present (Renamed_Entity (Actual))
- and then not In_Same_Source_Unit (I_Node,
- (Renamed_Entity (Actual))))
+ or else
+ (Present (Renamed_Entity (Actual))
+ and then not
+ In_Same_Source_Unit
+ (I_Node, (Renamed_Entity (Actual))))
then
null;
-- Finally we want to exclude such freeze nodes
-- from statement sequences, which freeze
-- everything before them.
- -- Is this strictly necesssary ???
+ -- Is this strictly necessary ???
Needs_Freezing := True;
+
S := Current_Scope;
while Present (S) loop
- if Ekind_In
- (S, E_Loop, E_Block, E_Procedure, E_Function)
+ if Ekind_In (S, E_Block,
+ E_Function,
+ E_Loop,
+ E_Procedure)
then
Needs_Freezing := False;
exit;
end if;
+
S := Scope (S);
end loop;
(Generic_Formal_Declarations (Original_Node (Gen_Decl)));
while Present (Formal_Decl) loop
Append_To
- (Decls, Copy_Generic_Node (Formal_Decl, Empty, True));
+ (Decls,
+ Copy_Generic_Node
+ (Formal_Decl, Empty, Instantiating => True));
Next (Formal_Decl);
end loop;
end;
Assoc := Associated_Node (Assoc);
end loop;
- -- Follow and additional link in case the final node was rewritten.
+ -- Follow an additional link in case the final node was rewritten.
-- This can only happen with nested generic units.
if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
-- An additional special case: an unconstrained type in an object
-- declaration may have been rewritten as a local subtype constrained
-- by the expression in the declaration. We need to recover the
- -- original entity which may be global.
+ -- original entity, which may be global.
if Present (Original_Node (Assoc))
and then Nkind (Parent (N)) = N_Object_Declaration
(New_N, Copy_Generic_List (Aspect_Specifications (N), Parent_Id));
end if;
- if Instantiating then
+ -- If we are instantiating, we want to adjust the sloc based on the
+ -- current S_Adjustment. However, if this is the root node of a subunit,
+ -- we need to defer that adjustment to below (see "elsif Instantiating
+ -- and Was_Stub"), so it comes after Create_Instantiation_Source has
+ -- computed the adjustment.
+
+ if Instantiating
+ and then not (Nkind (N) in N_Proper_Body
+ and then Was_Originally_Stub (N))
+ then
Adjust_Instantiation_Sloc (New_N, S_Adjustment);
end if;
Set_Selector_Name (New_N,
Copy_Generic_Node (Selector_Name (N), New_N, Instantiating));
- -- For operators, we must copy the right operand
+ -- For operators, copy the operands
elsif Nkind (N) in N_Op then
- Set_Right_Opnd (New_N,
- Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
-
- -- And for binary operators, the left operand as well
-
if Nkind (N) in N_Binary_Op then
Set_Left_Opnd (New_N,
Copy_Generic_Node (Left_Opnd (N), New_N, Instantiating));
end if;
+
+ Set_Right_Opnd (New_N,
+ Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
end if;
-- Establish a link between an entity from the generic template and the
Copy_Generic_List (Context_Items (N), New_N));
Set_Unit (New_N,
- Copy_Generic_Node (Unit (N), New_N, False));
+ Copy_Generic_Node (Unit (N), New_N, Instantiating => False));
Set_First_Inlined_Subprogram (New_N,
Copy_Generic_Node
- (First_Inlined_Subprogram (N), New_N, False));
+ (First_Inlined_Subprogram (N), New_N, Instantiating => False));
- Set_Aux_Decls_Node (New_N,
- Copy_Generic_Node (Aux_Decls_Node (N), New_N, False));
+ Set_Aux_Decls_Node
+ (New_N,
+ Copy_Generic_Node
+ (Aux_Decls_Node (N), New_N, Instantiating => False));
-- For an assignment node, the assignment is known to be semantically
-- legal if we are instantiating the template. This avoids incorrect
elsif Nkind (N) in N_Proper_Body then
declare
Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
-
begin
if Instantiating and then Was_Originally_Stub (N) then
Create_Instantiation_Source
(Instantiation_Node,
Defining_Entity (N),
S_Adjustment);
+
+ Adjust_Instantiation_Sloc (New_N, S_Adjustment);
end if;
-- Now copy the fields of the proper body, using the new
Copy_Descendants;
- -- Restore the original adjustment factor in case changed
+ -- Restore the original adjustment factor
S_Adjustment := Save_Adjustment;
end;
then
declare
Partial : constant Entity_Id :=
- Incomplete_Or_Partial_View (First_Subtype (Id));
+ Incomplete_Or_Partial_View (First_Subtype (Id));
begin
if Present (Partial)
and then Ekind (Partial) = E_Incomplete_Type
end loop;
end if;
- if Comes_From_Source (Ent) then
- Check_References (Ent);
- end if;
-
+ Check_References (Ent);
End_Scope;
if Unblocked_Exit_Count = 0 then
Preanalyze_Range (Iter_Name);
- -- Set the kind of the loop variable, which is not visible within
- -- the iterator name.
+ -- Set the kind of the loop variable, which is not visible within the
+ -- iterator name.
Set_Ekind (Def_Id, E_Variable);
return True;
+ elsif Nkind (Op) = N_Qualified_Expression then
+ return Compile_Time_Known_Value_Or_Aggr (Expression (Op));
+
-- All other types of values are not known at compile time
else
(Prag : Node_Id;
Spec_Id : Entity_Id);
-- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
- -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
- -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
+ -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
+ -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
+ -- and assertions are enabled.
procedure Check_State_And_Constituent_Use
(States : Elist_Id;
begin
if Warn_On_Redundant_Constructs
and then Has_Pragma_Inline_Always (Spec_Id)
+ and then Assertions_Enabled
then
Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Prag);
Prot_Type := Scope (E);
-- Bodies of entry families are nested within an extra scope
- -- that contains an entry index declaration
+ -- that contains an entry index declaration.
else
Prot_Type := Scope (Scope (E));
end if;
end if;
- -- Recurse into a nested package or non-internal block, but do not
- -- recurse into a formal package because the corresponding body is
- -- not analyzed.
+ -- Recurse into nested package or block. Do not recurse into a formal
+ -- package, because the corresponding body is not analyzed.
<<Continue>>
if (Is_Package_Or_Generic_Package (E1)
and then Nkind (Parent (E1)) = N_Package_Specification
and then
Nkind (Original_Node (Unit_Declaration_Node (E1))) /=
- N_Formal_Package_Declaration)
- or else (Ekind (E1) = E_Block and then not Is_Internal (E1))
+ N_Formal_Package_Declaration)
+
+ or else Ekind (E1) = E_Block
then
Check_References (E1);
end if;
-- case, but in practice there seem to be some nodes that get copied
-- twice, and this is a defence against that happening.
- if Factor.Lo <= Loc and then Loc <= Factor.Hi then
+ if Loc in Factor.Lo .. Factor.Hi then
Set_Sloc (N, Loc + Factor.Adjust);
end if;
end Adjust_Instantiation_Sloc;
Xnew := Source_File.Last;
if Debug_Flag_L then
- Write_Str ("Create_Instantiation_Source: created source ");
+ Write_Eol;
+ Write_Str ("*** Create_Instantiation_Source: created source ");
Write_Int (Int (Xnew));
Write_Line ("");
end if;
end;
if Debug_Flag_L then
- Write_Eol;
- Write_Str ("*** Create instantiation source for ");
+ Write_Str (" for ");
if Nkind (Dnod) in N_Proper_Body
and then Was_Originally_Stub (Dnod)
Write_Name (Chars (Template_Id));
Write_Eol;
- Write_Str (" new source index = ");
- Write_Int (Int (Xnew));
- Write_Eol;
-
Write_Str (" copying from file name = ");
Write_Name (File_Name (Xold));
Write_Eol;
X := Source_File.Last;
if Debug_Flag_L then
+ Write_Eol;
Write_Str ("Sinput.L.Load_File: created source ");
Write_Int (Int (X));
Write_Str (" for ");
Write_Str (Get_Name_String (N));
- Write_Line ("");
end if;
-- Compute starting index, respecting alignment requirement
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- Inst_Node is the instantiation node, and Template_Id is the defining
-- identifier of the generic declaration or body unit as appropriate.
-- Factor is set to an adjustment factor to be used in subsequent calls to
- -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used for
- -- inlined function and procedure calls. The parameter Inlined_Body is set
- -- to True in such cases. This is used for generating error messages that
- -- distinguish these two cases, otherwise the two cases are handled
- -- identically. Similarly, the instantiation mechanism is also used for
- -- inherited class-wide pre- and postconditions. Parameter Inherited_Pragma
- -- is set to True in such cases.
+ -- Adjust_Instantiation_Sloc. Template_Id can also be a subunit body that
+ -- replaces a stub in a generic unit.
+ --
+ -- The instantiation mechanism is also used for inlined function and
+ -- procedure calls. The parameter Inlined_Body is set to True in such
+ -- cases. This is used for generating error messages that distinguish these
+ -- two cases, otherwise the two cases are handled identically. Similarly,
+ -- the instantiation mechanism is also used for inherited class-wide pre-
+ -- and postconditions. Parameter Inherited_Pragma is set to True in such
+ -- cases.
private
projects / gcc.git / commitdiff