+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.
-- 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
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
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));
(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))));
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;
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
-- 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.
-- 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;
-- 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
Alts : List_Id;
DC : Node_Id;
DCH : List_Id;
- Expr : Node_Id;
Result : List_Id;
V : Node_Id;
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;
-----------------------
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
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
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)));
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
@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
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");
-- 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;
"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
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
"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
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);
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);
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;
------------------------
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 --
----------------
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;
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).
------------------------
projects / platform / upstream / linaro-gcc.git / commitdiff