+2013-10-10 Robert Dewar <dewar@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Redo duplicate/missing
+ choice circuit. Was not quite right in some cases, which showed
+ up in ACATS test B43201C.
+ * sem_attr.adb (Address_Checks): Make sure name is set right
+ for some messages issued.
+ * mlib-prj.adb: Minor code reorganization.
+ * gnat_ugn.texi: Remove special VMS doc for tagging of warning msgs.
+ * exp_ch9.adb: Minor reformatting.
+
+2013-10-10 Tristan Gingold <gingold@adacore.com>
+
+ * lib-writ.adb (Write_Unit_Information): Adjust previous patch.
+
+2013-10-10 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch5.adb (Analyze_If_Statement): Warn on redundant if
+ statement.
+ * sem_util.ads, sem_util.adb (Has_No_Obvious_Side_Effects): New
+ function.
+
+2013-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Timed_Entry_Call): Simplify expansion
+ for the case of a dispatching trigger: there is no need to
+ duplicate the code or create a subprogram to encapsulate the
+ triggering statements. This allows exit statements in the
+ triggering statements, that refer to enclosing loops.
+
2013-10-10 Robert Dewar <dewar@adacore.com>
* freeze.adb: Minor reformatting.
-- end if;
-- end;
- -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call;
+ -- 3) Ada 2005 (AI-345): When T.E is a dispatching procedure call, there
+ -- is no delay and the triggering statements are executed. We first
+ -- determine the kind of of the triggering call and then execute a
+ -- synchronized operation or a direct call.
-- declare
-- B : Boolean := False;
-- or else K = Ada.Tags.TK_Tagged
-- then
-- <dispatching-call>;
- -- <triggering-statements>
+ -- B := True;
-- else
-- S :=
-- then
-- <dispatching-call>;
-- end if;
-
- -- <triggering-statements>
- -- else
- -- <timed-statements>
- -- end if;
+ -- end if;
-- end if;
+
+ -- if B then
+ -- <triggering-statements>
+ -- else
+ -- <timed-statements>
+ -- end if;
-- end;
-- The triggering statement and the sequence of timed statements have not
-- been analyzed yet (see Analyzed_Timed_Entry_Call), but they may contain
- -- global references if within an instantiation. To prevent duplication
- -- between various uses of those statements, they are encapsulated into a
- -- local procedure which is invoked multiple time when the trigger is a
- -- dispatching call.
+ -- global references if within an instantiation.
procedure Expand_N_Timed_Entry_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
P : Entity_Id; -- Parameter block
S : Entity_Id; -- Primitive operation slot
- procedure Rewrite_Triggering_Statements;
- -- If the trigger is a dispatching call, the expansion inserts multiple
- -- copies of the abortable part. This is both inefficient, and may lead
- -- to duplicate definitions that the back-end will reject, when the
- -- abortable part includes loops. This procedure rewrites the abortable
- -- part into a call to a generated procedure.
-
- -----------------------------------
- -- Rewrite_Triggering_Statements --
- -----------------------------------
-
- procedure Rewrite_Triggering_Statements is
- Proc : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
- Decl : Node_Id;
- Stat : Node_Id;
-
- begin
- Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc, Defining_Unit_Name => Proc),
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, E_Stats));
-
- Append_To (Decls, Decl);
-
- -- Adjust the scope of blocks in the procedure. Needed because blocks
- -- generate declarations that are processed before other analysis
- -- takes place, and their scope is already set. The backend depends
- -- on the scope chain to determine the legality of some anonymous
- -- types, and thus we must indicate that the block is within the new
- -- procedure.
-
- Stat := First (E_Stats);
- while Present (Stat) loop
- if Nkind (Stat) = N_Block_Statement then
- Insert_Before (Stat,
- Make_Implicit_Label_Declaration (Sloc (Stat),
- Defining_Identifier =>
- Make_Defining_Identifier (
- Sloc (Stat), Chars (Identifier (Stat)))));
- end if;
-
- Next (Stat);
- end loop;
-
- -- Analyze (Decl);
-
- -- Rewrite abortable part into a call to this procedure.
-
- E_Stats :=
- New_List
- (Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc, Loc)));
- end Rewrite_Triggering_Statements;
-
-- Start of processing for Expand_N_Timed_Entry_Call
begin
if Is_Disp_Select then
Extract_Dispatching_Call (E_Call, Call_Ent, Obj, Actuals, Formals);
Decls := New_List;
- Rewrite_Triggering_Statements;
Stmts := New_List;
-- then
-- <dispatching-call>
-- end if;
- -- <triggering-statements>
- -- else
- -- <timed-statements>
-- end if;
- -- Note: we used to do Copy_Separate_List here, but this was changed
- -- to New_Copy_List_Tree with no explanation or RH note??? We should
- -- explain the need for the change ???
-
- N_Stats := New_Copy_List_Tree (E_Stats);
-
- Prepend_To (N_Stats,
+ N_Stats := New_List (
Make_Implicit_If_Statement (N,
-
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Append_To (Conc_Typ_Stmts,
Make_Implicit_If_Statement (N,
Condition => New_Reference_To (B, Loc),
- Then_Statements => N_Stats,
- Else_Statements => D_Stats));
+ Then_Statements => N_Stats));
-- Generate:
-- <dispatching-call>;
- -- <triggering-statements>
-
- -- Note: the following was Copy_Separate_List but it was changed to
- -- New_Copy_List_Tree without comments or RH documentation ??? We
- -- should explain the need for the change ???
+ -- B := True;
- Lim_Typ_Stmts := New_Copy_List_Tree (E_Stats);
- Prepend_To (Lim_Typ_Stmts, New_Copy_Tree (E_Call));
+ Lim_Typ_Stmts :=
+ New_List (New_Copy_Tree (E_Call),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (B, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
-- Generate:
-- if K = Ada.Tags.TK_Limited_Tagged
Then_Statements => Lim_Typ_Stmts,
Else_Statements => Conc_Typ_Stmts));
+ -- Generate:
+
+ -- if B then
+ -- <triggering-statements>
+ -- else
+ -- <timed-statements>
+ -- end if;
+
+ Append_To (Stmts,
+ Make_Implicit_If_Statement (N,
+ Condition => New_Occurrence_Of (B, Loc),
+ Then_Statements => E_Stats,
+ Else_Statements => D_Stats));
+
else
- -- Skip assignments to temporaries created for in-out parameters.
+ -- Simple case of a non-dispatching trigger. Skip assignments to
+ -- temporaries created for in-out parameters.
+
-- This makes unwarranted assumptions about the shape of the expanded
-- tree for the call, and should be cleaned up ???
This switch suppresses warnings for implicit dereferences in
indexed components, slices, and selected components.
-@ifclear vms
@item -gnatw.d
@emph{Activate tagging of warning messages.}
@cindex @option{-gnatw.d} (@command{gcc})
If this switch is set, then warning messages return to the default
mode in which warnings are not tagged as described above for
@code{-gnatw.d}.
-@end ifclear
-
-@ifset vms
-@item -gnatw.d
-@emph{Activate tagging of warning messages.}
-@cindex @option{-gnatw.d} (@command{gcc})
-If this switch is set, then warning messages are tagged, either with
-the appropriate WARNINGS qualifier string (e.g. [SUSPICIOUS_MODULUS]
-or with ``[enabled by default]'' if the warning is not under control of a
-specific WARNING qualifier switch. This mode is off by default, and is not
-affected by the use of @code{-gnatwa}.
-
-@item -gnatw.D
-@emph{Deactivate tagging of warning messages.}
-@cindex @option{-gnatw.d} (@command{gcc})
-If this switch is set, then warning messages return to the default
-mode in which warnings are not tagged as described above for
-@code{-gnatw.d}.
-@end ifset
@item -gnatwe
@emph{Treat warnings and style checks as errors.}
if Is_Generic_Unit (Cunit_Entity (Main_Unit))
and then
Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ and then Linker_Option_Lines.Table (J).Unit = Unit_Num
then
Set_Standard_Error;
Write_Line
Delete_File (Get_Name_String (Path), Succ);
- if not Succ then
- null;
- end if;
+ -- We ignore a failure in this Delete_File operation.
+ -- Is that OK??? If so, worth a comment as to why we
+ -- are OK with the operation failing
end;
end if;
package body Sem_Aggr is
type Case_Bounds is record
- Choice_Lo : Node_Id;
- Choice_Hi : Node_Id;
- Choice_Node : Node_Id;
+ Lo : Node_Id;
+ -- Low bound of choice. Once we sort the Case_Table, then entries
+ -- will be in order of ascending Choice_Lo values.
+
+ Hi : Node_Id;
+ -- High Bound of choice. The sort does not pay any attention to the
+ -- high bound, so choices 1 .. 4 and 1 .. 5 could be in either order.
+
+ Highest : Uint;
+ -- If there are duplicates or missing entries, then in the sorted
+ -- table, this records the highest value among Choice_Hi values
+ -- seen so far, including this entry.
+
+ Choice : Node_Id;
+ -- The node of the choice
end record;
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
- -- Table type used by Check_Case_Choices procedure
+ -- Table type used by Check_Case_Choices procedure. Entry zero is not
+ -- used (reserved for the sort). Real entries start at one.
-----------------------
-- Local Subprograms --
-----------------------
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
- -- Sort the Case Table using the Lower Bound of each Choice as the key.
- -- A simple insertion sort is used since the number of choices in a case
- -- statement of variant part will usually be small and probably in near
- -- sorted order.
+ -- Sort the Case Table using the Lower Bound of each Choice as the key. A
+ -- simple insertion sort is used since the choices in a case statement will
+ -- usually be in near sorted order.
procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
-- Ada 2005 (AI-231): Check bad usage of null for a component for which
-- if a choice in an aggregate is a subtype indication these
-- denote the lowest and highest values of the subtype
- Table : Case_Table_Type (1 .. Case_Table_Size);
- -- Used to sort all the different choice values
+ Table : Case_Table_Type (0 .. Case_Table_Size);
+ -- Used to sort all the different choice values. Entry zero is
+ -- reserved for sorting purposes.
Single_Choice : Boolean;
-- Set to true every time there is a single discrete choice in a
end if;
Nb_Discrete_Choices := Nb_Discrete_Choices + 1;
- Table (Nb_Discrete_Choices).Choice_Lo := Low;
- Table (Nb_Discrete_Choices).Choice_Hi := High;
- Table (Nb_Discrete_Choices).Choice_Node := Choice;
+ Table (Nb_Discrete_Choices).Lo := Low;
+ Table (Nb_Discrete_Choices).Hi := High;
+ Table (Nb_Discrete_Choices).Choice := Choice;
Next (Choice);
-- High end of one range and Low end of the next. Should be
-- contiguous if there is no hole in the list of values.
+ Lo_Dup : Uint;
+ Hi_Dup : Uint;
+ -- End points of duplicated range
+
Missing_Or_Duplicates : Boolean := False;
-- Set True if missing or duplicate choices found
begin
Sort_Case_Table (Table);
- -- Loop through entries in table to find duplicate indexes
+ -- First we do a quick linear loop to find out if we have
+ -- any duplicates or missing entries (usually we have a
+ -- legal aggregate, so this will get us out quickly).
for J in 1 .. Nb_Discrete_Choices - 1 loop
- Hi_Val := Expr_Value (Table (J).Choice_Hi);
- Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
-
- if Hi_Val >= Lo_Val then
- Choice := Table (J + 1).Choice_Lo;
- Error_Msg_Sloc := Sloc (Table (J).Choice_Hi);
-
- if Hi_Val = Lo_Val then
- Error_Msg_N
- ("index value in array aggregate duplicates "
- & "the one given#",
- Choice);
- else
- Error_Msg_N
- ("index values in array aggregate duplicate "
- & "those given#", Choice);
- end if;
+ Hi_Val := Expr_Value (Table (J).Hi);
+ Lo_Val := Expr_Value (Table (J + 1).Lo);
+ if Lo_Val <= Hi_Val
+ or else (Lo_Val > Hi_Val + 1
+ and then not Others_Present)
+ then
Missing_Or_Duplicates := True;
- Output_Bad_Choices (Lo_Val, Hi_Val, Choice);
+ exit;
end if;
end loop;
- -- Loop through entries in table to find missing indexes.
- -- Not needed if others present, since missing impossible.
+ -- If we have missing or duplicate entries, first fill in
+ -- the Highest entries to make life easier in the following
+ -- loops to detect bad entries.
- if not Others_Present then
- for J in 1 .. Nb_Discrete_Choices - 1 loop
- Hi_Val := Expr_Value (Table (J).Choice_Hi);
- Lo_Val := Expr_Value (Table (J + 1).Choice_Lo);
+ if Missing_Or_Duplicates then
+ Table (1).Highest := Expr_Value (Table (1).Hi);
- if Hi_Val < Lo_Val - 1 then
- Choice := Table (J + 1).Choice_Lo;
+ for J in 2 .. Nb_Discrete_Choices loop
+ Table (J).Highest :=
+ UI_Max
+ (Table (J - 1).Highest, Expr_Value (Table (J).Hi));
+ end loop;
- if Hi_Val + 1 = Lo_Val - 1 then
- Error_Msg_N
- ("missing index value in array aggregate!",
- Choice);
- else
- Error_Msg_N
- ("missing index values in array aggregate!",
- Choice);
- end if;
+ -- Loop through table entries to find duplicate indexes
+
+ for J in 2 .. Nb_Discrete_Choices loop
+ Lo_Val := Expr_Value (Table (J).Lo);
+ Hi_Val := Expr_Value (Table (J).Hi);
+
+ -- Case where we have duplicates (the lower bound of
+ -- this choice is less than or equal to the highest
+ -- high bound found so far).
+
+ if Lo_Val <= Table (J - 1).Highest then
+
+ -- We move backwards looking for duplicates. We can
+ -- abandon this loop as soon as we reach a choice
+ -- highest value that is less than Lo_Val.
+
+ for K in reverse 1 .. J - 1 loop
+ exit when Table (K).Highest < Lo_Val;
+
+ -- Here we may have duplicates between entries
+ -- for K and J. Get range of duplicates.
+
+ Lo_Dup :=
+ UI_Max (Lo_Val, Expr_Value (Table (K).Lo));
+ Hi_Dup :=
+ UI_Min (Hi_Val, Expr_Value (Table (K).Hi));
+
+ -- Nothing to do if duplicate range is null
- Missing_Or_Duplicates := True;
- Output_Bad_Choices (Hi_Val + 1, Lo_Val - 1, Choice);
+ if Lo_Dup > Hi_Dup then
+ null;
+
+ -- Otherwise place proper message
+
+ else
+ -- We place message on later choice, with a
+ -- line reference to the earlier choice.
+
+ if Sloc (Table (J).Choice) <
+ Sloc (Table (K).Choice)
+ then
+ Choice := Table (K).Choice;
+ Error_Msg_Sloc := Sloc (Table (J).Choice);
+ else
+ Choice := Table (J).Choice;
+ Error_Msg_Sloc := Sloc (Table (K).Choice);
+ end if;
+
+ if Lo_Dup = Hi_Dup then
+ Error_Msg_N
+ ("index value in array aggregate "
+ & "duplicates the one given#!", Choice);
+ else
+ Error_Msg_N
+ ("index values in array aggregate "
+ & "duplicate those given#!", Choice);
+ end if;
+
+ Output_Bad_Choices (Lo_Dup, Hi_Dup, Choice);
+ end if;
+ end loop;
end if;
end loop;
- end if;
- -- If either missing or duplicate values, return failure
+ -- Loop through entries in table to find missing indexes.
+ -- Not needed if others, since missing impossible.
+
+ if not Others_Present then
+ for J in 2 .. Nb_Discrete_Choices loop
+ Lo_Val := Expr_Value (Table (J).Lo);
+ Hi_Val := Table (J - 1).Highest;
+
+ if Lo_Val > Hi_Val + 1 then
+ Choice := Table (J).Lo;
+
+ if Hi_Val + 1 = Lo_Val - 1 then
+ Error_Msg_N
+ ("missing index value in array aggregate!",
+ Choice);
+ else
+ Error_Msg_N
+ ("missing index values in array aggregate!",
+ Choice);
+ end if;
+
+ Output_Bad_Choices
+ (Hi_Val + 1, Lo_Val - 1, Choice);
+ end if;
+ end loop;
+ end if;
+
+ -- If either missing or duplicate values, return failure
- if Missing_Or_Duplicates then
Set_Etype (N, Any_Composite);
return Failure;
end if;
-- STEP 2 (B): Compute aggregate bounds and min/max choices values
if Nb_Discrete_Choices > 0 then
- Choices_Low := Table (1).Choice_Lo;
- Choices_High := Table (Nb_Discrete_Choices).Choice_Hi;
+ Choices_Low := Table (1).Lo;
+ Choices_High := Table (Nb_Discrete_Choices).Hi;
end if;
-- If Others is present, then bounds of aggregate come from the
Check_Unset_Reference (Aggregate_Bounds (N));
if not Others_Present and then Nb_Discrete_Choices = 0 then
- Set_High_Bound (Aggregate_Bounds (N),
- Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
+ Set_High_Bound
+ (Aggregate_Bounds (N),
+ Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N))));
end if;
-- Check the dimensions of each component in the array aggregate
---------------------
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
- L : constant Int := Case_Table'First;
U : constant Int := Case_Table'Last;
K : Int;
J : Int;
T : Case_Bounds;
begin
- K := L;
- while K /= U loop
+ K := 1;
+ while K < U loop
T := Case_Table (K + 1);
J := K + 1;
- while J /= L
- and then Expr_Value (Case_Table (J - 1).Choice_Lo) >
- Expr_Value (T.Choice_Lo)
+ while J > 1
+ and then Expr_Value (Case_Table (J - 1).Lo) > Expr_Value (T.Lo)
loop
Case_Table (J) := Case_Table (J - 1);
J := J - 1;
Reason => PE_Address_Of_Intrinsic));
else
+ Error_Msg_Name_1 := Aname;
Error_Msg_N
("cannot take % of intrinsic subprogram", N);
end if;
Remove_Warning_Messages (Then_Statements (N));
end if;
end if;
+
+ -- Warn on redundant if statement that has no effect
+
+ if Warn_On_Redundant_Constructs
+
+ -- Condition must not have obvious side effect
+
+ and then Has_No_Obvious_Side_Effects (Condition (N))
+
+ -- No elsif parts of else part
+
+ and then No (Elsif_Parts (N))
+ and then No (Else_Statements (N))
+
+ -- Then must be a single null statement
+
+ and then List_Length (Then_Statements (N)) = 1
+ then
+ -- Go to original node, since we may have rewritten something as
+ -- a null statement (e.g. a case we could figure the outcome of).
+
+ declare
+ T : constant Node_Id := First (Then_Statements (N));
+ S : constant Node_Id := Original_Node (T);
+
+ begin
+ if Comes_From_Source (S) and then Nkind (S) = N_Null_Statement then
+ Error_Msg_N ("if statement has no effect?r?", N);
+ end if;
+ end;
+ end if;
end Analyze_If_Statement;
----------------------------------------
return False;
end Has_Interfaces;
+ ---------------------------------
+ -- Has_No_Obvious_Side_Effects --
+ ---------------------------------
+
+ function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
+ begin
+ -- For now, just handle literals, constants, and non-volatile
+ -- variables and expressions combining these with operators or
+ -- short circuit forms.
+
+ if Nkind (N) in N_Numeric_Or_String_Literal then
+ return True;
+
+ elsif Nkind (N) = N_Character_Literal then
+ return True;
+
+ elsif Nkind (N) in N_Unary_Op then
+ return Has_No_Obvious_Side_Effects (Right_Opnd (N));
+
+ elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
+ return Has_No_Obvious_Side_Effects (Left_Opnd (N))
+ and then
+ Has_No_Obvious_Side_Effects (Right_Opnd (N));
+
+ elsif Nkind (N) in N_Has_Entity then
+ return Present (Entity (N))
+ and then Ekind_In (Entity (N), E_Variable,
+ E_Constant,
+ E_Enumeration_Literal,
+ E_In_Parameter,
+ E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then not Is_Volatile (Entity (N));
+
+ else
+ return False;
+ end if;
+ end Has_No_Obvious_Side_Effects;
+
------------------------
-- Has_Null_Exclusion --
------------------------
-- Use_Full_View controls if the check is done using its full view (if
-- available).
+ function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
+ -- This is a simple minded function for determining whether an expression
+ -- has no obvious side effects. It is used only for determining whether
+ -- warnings are needed in certain situations, and is not guaranteed to
+ -- be accurate in either direction. Exceptions may mean an expression
+ -- does in fact have side effects, but this may be ignored and True is
+ -- returned, or a complex expression may in fact be side effect free
+ -- but we don't recognize it here and return False. The Side_Effect_Free
+ -- routine in Remove_Side_Effects is much more extensive and perhaps could
+ -- be shared, so that this routine would be more accurate.
+
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
projects / gcc.git / commitdiff