Skip to content

R
riscv-gcc-1
Commit 9db0b232 by Arnaud Charlet
Options

[multiple changes] 

2010-10-04  Bob Duff  <duff@adacore.com>

	* sem_res.adb (Resolve_Type_Conversion): If a type conversion is needed
	to make a qualified expression into a name (syntax-wise), then do not
	consider it redundant.

2010-10-04  Thomas Quinot  <quinot@adacore.com>

	* sem_warn.ads: Fix typo.

2010-10-04  Javier Miranda  <miranda@adacore.com>

	* exp_cg.adb (Is_Predefined_Dispatching_Operation): Handle suffix in
	TSS names.
	(Write_Call_Info): Add missing support for renamed primitives.

2010-10-04  Thomas Quinot  <quinot@adacore.com>

	* exp_ch5.adb (Make_Field_Expr): New subprogram, to factor duplicated
	code between Make_Component_List_Assign and Make_Field_Assign.

2010-10-04  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb (Get_Directories): For non extending projects that
	declare that they have no sources, do not create a non existing object
	or exec directory if builder switch -p is used.

2010-10-04  Sergey Rybin  <rybin@adacore.com>

	* gnat_ugn.texi (gnatcheck): Change the description of the report file
	format.

2010-10-04  Ed Falis  <falis@adacore.com>

	* s-taprop-vxworks.adb (Is_Task_Context): Import VxWorks intContext to
	determine whether Set_True is called from a task or an ISR.
	(Set_True): test for being in a task context before trying to
	dereference Defer_Abort or Undefer_Abort.

From-SVN: r164936
parent 477bd732
Showing with 198 additions and 105 deletions
gcc/ada/ChangeLog
2010-10-04 Bob Duff <duff@adacore.com>
* sem_res.adb (Resolve_Type_Conversion): If a type conversion is needed
to make a qualified expression into a name (syntax-wise), then do not
consider it redundant.
2010-10-04 Thomas Quinot <quinot@adacore.com>
* sem_warn.ads: Fix typo.
2010-10-04 Javier Miranda <miranda@adacore.com>
* exp_cg.adb (Is_Predefined_Dispatching_Operation): Handle suffix in
TSS names.
(Write_Call_Info): Add missing support for renamed primitives.
2010-10-04 Thomas Quinot <quinot@adacore.com>
* exp_ch5.adb (Make_Field_Expr): New subprogram, to factor duplicated
code between Make_Component_List_Assign and Make_Field_Assign.
2010-10-04 Vincent Celier <celier@adacore.com>
* prj-nmsc.adb (Get_Directories): For non extending projects that
declare that they have no sources, do not create a non existing object
or exec directory if builder switch -p is used.
2010-10-04 Sergey Rybin <rybin@adacore.com>
* gnat_ugn.texi (gnatcheck): Change the description of the report file
format.
2010-10-04 Ed Falis <falis@adacore.com>
* s-taprop-vxworks.adb (Is_Task_Context): Import VxWorks intContext to
determine whether Set_True is called from a task or an ISR.
(Set_True): test for being in a task context before trying to
dereference Defer_Abort or Undefer_Abort.
2010-10-04 Robert Dewar <dewar@adacore.com>
* sem_res.adb, sinput-l.adb: Minor reformatting.
......
gcc/ada/exp_cg.adb
......@@ -213,8 +213,9 @@ package body Exp_CG is
-- Local variables
Full_Name : constant String := Get_Name_String (Chars (E));
TSS_Name : TSS_Name_Type;
Full_Name : constant String := Get_Name_String (Chars (E));
Suffix_Length : Natural := Homonym_Suffix_Length (E);
TSS_Name : TSS_Name_Type;
-- Start of processing for Is_Predefined_Dispatching_Operation
......@@ -223,14 +224,31 @@ package body Exp_CG is
return False;
end if;
-- Search for and strip suffix for body-nested package entities
for J in reverse Full_Name'First + 2 .. Full_Name'Last loop
if Full_Name (J) = 'X' then
-- Include the "X", "Xb", "Xn", ... in the part of the
-- suffix to be removed.
Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
exit;
end if;
exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
end loop;
-- Most predefined primitives have internally generated names. Equality
-- must be treated differently; the predefined operation is recognized
-- as a homogeneous binary operator that returns Boolean.
if Full_Name'Length > TSS_Name_Type'Length then
TSS_Name :=
TSS_Name_Type (Full_Name (Full_Name'Last - TSS_Name'Length + 1
.. Full_Name'Last));
TSS_Name_Type
(Full_Name
(Full_Name'Last - TSS_Name'Length - Suffix_Length + 1
.. Full_Name'Last - Suffix_Length));
if TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
......@@ -273,25 +291,7 @@ package body Exp_CG is
Name_uDisp_Requeue,
Name_uDisp_Timed_Select);
Suffix_Length : Natural;
begin
-- Search for and strip suffix for body-nested package entities
Suffix_Length := Homonym_Suffix_Length (E);
for J in reverse Full_Name'First + 2 .. Full_Name'Last loop
if Full_Name (J) = 'X' then
-- Include the "X", "Xb", "Xn", ... in the part of the
-- suffix to be removed.
Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
exit;
end if;
exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
end loop;
for J in Predef_Names_95'Range loop
Get_Name_String (Predef_Names_95 (J));
......@@ -476,7 +476,12 @@ package body Exp_CG is
(Find_Dispatching_Type (Ultimate_Alias (Prim)),
Root_Type (Ctrl_Typ))
then
Write_Int (UI_To_Int (Slot_Number (Ultimate_Alias (Prim))));
-- This is a special case in which we generate in the ci file the
-- slot number of the renaming primitive (i.e. Base2) but instead of
-- generating the name of this renaming entity we reference directly
-- the renamed entity (i.e. Base).
Write_Int (UI_To_Int (Slot_Number (Prim)));
Write_Char (':');
Write_Name
(Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
......@@ -569,9 +574,10 @@ package body Exp_CG is
while Present (Elmt) loop
Prim := Node (Elmt);
-- Display only primitives overriden or defined
-- Skip internal entities associated with overridden interface
-- primitives
if Present (Alias (Prim)) then
if Present (Interface_Alias (Prim)) then
goto Continue;
end if;
......@@ -587,7 +593,14 @@ package body Exp_CG is
Write_Int (UI_To_Int (Slot_Number (Prim)));
Write_Char (':');
Write_Name (Chars (Prim));
-- Handle renamed primitives
if Present (Alias (Prim)) then
Write_Name (Chars (Ultimate_Alias (Prim)));
else
Write_Name (Chars (Prim));
end if;
-- Display overriding of parent primitives
......
gcc/ada/exp_ch5.adb
......@@ -1041,7 +1041,7 @@ package body Exp_Ch5 is
-- Note that on the last iteration of the loop, the index is increased
-- (or decreased) past the corresponding bound. This is consistent with
-- the C semantics of the back-end, where such an off-by-one value on a
-- dead index variable is OK. However, in CodePeer mode this leads to
-- dead index variable is OK. However, in CodePeer mode this leads to
-- spurious warnings, and thus we place a guard around the attribute
-- reference. For obvious reasons we only do this for CodePeer.
......@@ -1223,6 +1223,13 @@ package body Exp_Ch5 is
-- declaration for Typ. We need to use the actual entity because the
-- type may be private and resolution by identifier alone would fail.
function Make_Field_Expr
(Comp_Ent : Entity_Id;
U_U : Boolean) return Node_Id;
-- Common processing for one component for Make_Component_List_Assign
-- and Make_Field_Assign. Return the expression to be assigned for
-- component Comp_Ent.
function Make_Component_List_Assign
(CL : Node_Id;
U_U : Boolean := False) return List_Id;
......@@ -1232,7 +1239,7 @@ package body Exp_Ch5 is
-- part expression as the switch for the generated case statement.
function Make_Field_Assign
(C : Entity_Id;
(C : Entity_Id;
U_U : Boolean := False) return Node_Id;
-- Given C, the entity for a discriminant or component, build an
-- assignment for the corresponding field values. The flag U_U
......@@ -1282,7 +1289,6 @@ package body Exp_Ch5 is
Alts : List_Id;
DC : Node_Id;
DCH : List_Id;
Expr : Node_Id;
Result : List_Id;
V : Node_Id;
......@@ -1308,28 +1314,9 @@ package body Exp_Ch5 is
Next_Non_Pragma (V);
end loop;
-- If we have an Unchecked_Union, use the value of the inferred
-- discriminant of the variant part expression as the switch
-- for the case statement. The case statement may later be
-- folded.
if U_U then
Expr :=
New_Copy (Get_Discriminant_Value (
Entity (Name (VP)),
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name =>
Make_Identifier (Loc, Chars (Name (VP))));
end if;
Append_To (Result,
Make_Case_Statement (Loc,
Expression => Expr,
Expression => Make_Field_Expr (Entity (Name (VP)), U_U),
Alternatives => Alts));
end if;
......@@ -1341,36 +1328,23 @@ package body Exp_Ch5 is
-----------------------
function Make_Field_Assign
(C : Entity_Id;
(C : Entity_Id;
U_U : Boolean := False) return Node_Id
is
A : Node_Id;
Expr : Node_Id;
begin
-- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right hand side of the assignment.
if U_U then
Expr :=
New_Copy (Get_Discriminant_Value (C,
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (C, Loc));
end if;
A :=
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
Expression => Expr);
Expression => Make_Field_Expr (C, U_U));
-- Set Assignment_OK, so discriminants can be assigned
......@@ -1395,8 +1369,9 @@ package body Exp_Ch5 is
Result : List_Id;
begin
Item := First (CI);
Result := New_List;
Item := First (CI);
while Present (Item) loop
-- Look for components, but exclude _tag field assignment if
......@@ -1404,7 +1379,7 @@ package body Exp_Ch5 is
if Nkind (Item) = N_Component_Declaration
and then not (Is_Tag (Defining_Identifier (Item))
and then Componentwise_Assignment (N))
and then Componentwise_Assignment (N))
then
Append_To
(Result, Make_Field_Assign (Defining_Identifier (Item)));
......@@ -1416,6 +1391,32 @@ package body Exp_Ch5 is
return Result;
end Make_Field_Assigns;
---------------------
-- Make_Field_Expr --
---------------------
function Make_Field_Expr
(Comp_Ent : Entity_Id;
U_U : Boolean) return Node_Id
is
begin
-- If we have an Unchecked_Union, use the value of the inferred
-- discriminant of the variant part expression.
if U_U then
return
New_Copy (Get_Discriminant_Value
(Comp_Ent,
Etype (Rhs),
Discriminant_Constraint (Etype (Rhs))));
else
return
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (Comp_Ent, Loc));
end if;
end Make_Field_Expr;
-- Start of processing for Expand_Assign_Record
begin
......
gcc/ada/gnat_ugn.texi
......@@ -17291,21 +17291,24 @@ supplied.
@cindex Report file (for @code{gnatcheck})
@noindent
The @command{gnatcheck} tool outputs on @file{stdout} all messages concerning
rule violations.
It also creates a text file that
contains the complete report of the last gnatcheck run. By default this file
is named named @file{^gnatcheck.out^GNATCHECK.OUT^} and it is located in the
The @command{gnatcheck} tool outputs on @file{stderr} all messages concerning
rule violations except if running in quiet mode. It also creates a text file
that contains the complete report of the last gnatcheck run. By default this file
is named @file{^gnatcheck.out^GNATCHECK.OUT^} and it is located in the
current directory; the @option{^-o^/OUTPUT^} option can be used to change the
name and/or location of the report file. This report contains:
@itemize @bullet
@item date and time of @command{gnatcheck} run, the version of
the tool that has generated this report and the full parameters
of the @command{gnatcheck} invocation;
@item list of enabled rules;
@item total number of detected violations;
@item list of source files where rule violations have been detected;
@item list of source files where no violations have been detected.
@item general details of the @command{gnatcheck} run: date and time of the run,
the version of the tool that has generated this report, full parameters
of the @command{gnatcheck} invocation, reference to the list of checked
sources and applied rules (coding standard);
@item summary of the run (number of checked sources and detected violations);
@item list of exempted coding standard violations;
@item list of non-exempted coding standard violations;
@item list of problems in the definition of exemption sections;
@item of language violations (compile-time errors) detected in processed sources;
@end itemize
@node General gnatcheck Switches
......
gcc/ada/prj-nmsc.adb
......@@ -5280,10 +5280,18 @@ package body Prj.Nmsc is
Recursive_Dirs.Reset (Visited);
end Find_Source_Dirs;
-- Start of processing for Get_Directories
Dir_Exists : Boolean;
No_Sources : constant Boolean :=
(((not Source_Files.Default) and then Source_Files.Values = Nil_String)
or else
((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String)
or else
((not Languages.Default) and then Languages.Values = Nil_String))
and then Project.Extends = No_Project;
-- Start of processing for Get_Directories
begin
if Current_Verbosity = High then
Write_Line ("Starting to look for directories");
......@@ -5292,14 +5300,7 @@ package body Prj.Nmsc is
-- Set the object directory to its default which may be nil, if there
-- is no sources in the project.
if (((not Source_Files.Default)
and then Source_Files.Values = Nil_String)
or else
((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String)
or else
((not Languages.Default) and then Languages.Values = Nil_String))
and then Project.Extends = No_Project
then
if No_Sources then
Project.Object_Directory := No_Path_Information;
else
Project.Object_Directory := Project.Directory;
......@@ -5316,7 +5317,7 @@ package body Prj.Nmsc is
"Object_Dir cannot be empty",
Object_Dir.Location, Project);
else
elsif not No_Sources then
-- We check that the specified object directory does exist.
-- However, even when it doesn't exist, we set it to a default
-- value. This is for the benefit of tools that recover from
......@@ -5348,9 +5349,7 @@ package body Prj.Nmsc is
end if;
end if;
elsif Project.Object_Directory /= No_Path_Information
and then Subdirs /= null
then
elsif not No_Sources and then Subdirs /= null then
Name_Len := 1;
Name_Buffer (1) := '.';
Locate_Directory
......@@ -5389,7 +5388,7 @@ package body Prj.Nmsc is
"Exec_Dir cannot be empty",
Exec_Dir.Location, Project);
else
elsif not No_Sources then
-- We check that the specified exec directory does exist
Locate_Directory
......
gcc/ada/s-taprop-vxworks.adb
......@@ -163,6 +163,10 @@ package body System.Task_Primitives.Operations is
procedure Install_Signal_Handlers;
-- Install the default signal handlers for the current task
function Is_Task_Context return Boolean;
-- This function returns True if the current execution is in the context
-- of a task, and False if it is an interrupt context.
function To_Address is
new Ada.Unchecked_Conversion (Task_Id, System.Address);
......@@ -1095,7 +1099,12 @@ package body System.Task_Primitives.Operations is
Result : STATUS;
begin
SSL.Abort_Defer.all;
-- Set_True can be called from an interrupt context, in which case
-- Abort_Defer is undefined.
if Is_Task_Context then
SSL.Abort_Defer.all;
end if;
Result := semTake (S.L, WAIT_FOREVER);
pragma Assert (Result = OK);
......@@ -1118,7 +1127,12 @@ package body System.Task_Primitives.Operations is
Result := semGive (S.L);
pragma Assert (Result = OK);
SSL.Abort_Undefer.all;
-- Set_True can be called from an interrupt context, in which case
-- Abort_Undefer is undefined.
if Is_Task_Context then
SSL.Abort_Undefer.all;
end if;
end Set_True;
------------------------
......@@ -1316,6 +1330,19 @@ package body System.Task_Primitives.Operations is
end if;
end Continue_Task;
---------------------
-- Is_Task_Context --
---------------------
function Is_Task_Context return Boolean is
function intContext return int;
-- Binding to the C routine intContext. This function returns 1 only
-- if the current execution state is an interrupt context.
pragma Import (C, intContext, "intContext");
begin
return intContext /= 1;
end Is_Task_Context;
----------------
-- Initialize --
----------------
......
gcc/ada/sem_res.adb
......@@ -8843,15 +8843,26 @@ package body Sem_Res is
then
null;
-- Finally, the expression may be a qualified expression whose
-- own expression is a possibly overloaded function call. The
-- qualified expression is needed to be disambiguate the call,
-- but it appears in a context in which a name is needed, forcing
-- the use of a conversion. In Ada 2012, a qualified expression is
-- a name, and this idiom is no longer needed.
-- Finally, if this type conversion occurs in a context that
-- requires a prefix, and the expression is a qualified
-- expression, then the type conversion is not redundant,
-- because a qualified expression is not a prefix, whereas a
-- type conversion is. For example, "X := T'(Funx(...)).Y;" is
-- illegal. because a selected component requires a prefix, but
-- a type conversion makes it legal: "X := T(T'(Funx(...))).Y;"
-- In Ada 2012, a qualified expression is a name, so this idiom is
-- no longer needed, but we still suppress the warning because it
-- seems unfriendly for warnings to pop up when you switch to the
-- newer language version.
elsif Nkind (Orig_N) = N_Qualified_Expression
and then Nkind (Expression (Orig_N)) = N_Function_Call
and then Nkind_In
(Parent (N),
N_Attribute_Reference,
N_Indexed_Component,
N_Selected_Component,
N_Slice,
N_Explicit_Dereference)
then
null;
......
gcc/ada/sem_warn.ads
......@@ -50,7 +50,7 @@ package Sem_Warn is
Warn_On_Overridden_Size : Boolean := False;
-- Warn when explicit record component clause or array component_size
-- clause specifies a size that overrides a size for the typen which was
-- set with an explicit size clause. Off by default, set by -gnatw.sn (but
-- set with an explicit size clause. Off by default, set by -gnatw.s (but
-- not -gnatwa).
------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment