[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
This commit is contained in:
Arnaud Charlet
parent
477bd73273
commit
9db0b2326f
@ -1,3 +1,42 @@
|
||||
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.
|
||||
|
||||
@ -214,6 +214,7 @@ package body Exp_CG is
|
||||
-- Local variables
|
||||
|
||||
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 (':');
|
||||
|
||||
-- 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
|
||||
|
||||
|
||||
@ -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;
|
||||
@ -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;
|
||||
|
||||
@ -1345,24 +1332,11 @@ package body Exp_Ch5 is
|
||||
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 =>
|
||||
@ -1370,7 +1344,7 @@ package body Exp_Ch5 is
|
||||
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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
-- 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);
|
||||
|
||||
-- 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 --
|
||||
----------------
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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).
|
||||
|
||||
------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user