OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2014-07-30  Vincent Celier  <celier@adacore.com>

	* debug.adb: Minor comment update.

2014-07-30  Robert Dewar  <dewar@adacore.com>

	* s-tasuti.adb, s-tassta.adb: Minor reformatting.
	* sprint.adb (Sprint_Node): Handle N_Contract case.
	* exp_prag.adb: Minor reformatting.
	* freeze.adb (Freeze_Entity): Check useless postcondition for
	No_Return subprogram.
	* sem_prag.adb: Minor reformatting.

2014-07-30  Javier Miranda  <miranda@adacore.com>

	* a-tags.ads: Complete comments about performance.

2014-07-30  Fedor Rybin  <frybin@adacore.com>

	* gnat_ugn.texi: Adding description for --exit-status option to
	gnattest section.  Fixing index entry of --passed-tests option
	in gnattest section.

2014-07-30  Javier Miranda  <miranda@adacore.com>

	* Makefile.rtl, gnat_rm.texi, i-cpp.adb, i-cpp.ads, impunit.adb,
	rtsfind.ads: Remove references to package Interfaces.CPP since this
	package is no longer needed.

From-SVN: r213270
This commit is contained in:
Arnaud Charlet 2014-07-30 15:53:11 +02:00
parent fccaf220f3
commit d3e16619ae
16 changed files with 190 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2014-07-30 Vincent Celier <celier@adacore.com>
* debug.adb: Minor comment update.
2014-07-30 Robert Dewar <dewar@adacore.com>
* s-tasuti.adb, s-tassta.adb: Minor reformatting.
* sprint.adb (Sprint_Node): Handle N_Contract case.
* exp_prag.adb: Minor reformatting.
* freeze.adb (Freeze_Entity): Check useless postcondition for
No_Return subprogram.
* sem_prag.adb: Minor reformatting.
2014-07-30 Javier Miranda <miranda@adacore.com>
* a-tags.ads: Complete comments about performance.
2014-07-30 Fedor Rybin <frybin@adacore.com>
* gnat_ugn.texi: Adding description for --exit-status option to
gnattest section. Fixing index entry of --passed-tests option
in gnattest section.
2014-07-30 Javier Miranda <miranda@adacore.com>
* Makefile.rtl, gnat_rm.texi, i-cpp.adb, i-cpp.ads, impunit.adb,
rtsfind.ads: Remove references to package Interfaces.CPP since this
package is no longer needed.
2014-07-30 Bob Duff <duff@adacore.com>
* s-taasde.adb (Timer_Queue): Don't use a

1
gcc/ada/Makefile.rtl
View File

@ -470,7 +470,6 @@ GNATRTL_NONTASKING_OBJS= \
i-cexten$(objext) \
i-cobol$(objext) \
i-cpoint$(objext) \
i-cpp$(objext) \
i-cstrea$(objext) \
i-cstrin$(objext) \
i-fortra$(objext) \

4
gcc/ada/a-tags.ads
View File

@ -44,7 +44,7 @@
-- time (in terms of source lines executed):
-- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag,
-- Is_Descendant_At_Same_Level, Parent_Tag
-- Is_Descendant_At_Same_Level, Parent_Tag, Type_Is_Abstract
-- Descendant_Tag (when used with a library-level tagged type),
-- Internal_Tag (when used with a library-level tagged type).
@ -53,7 +53,7 @@
-- Descendant_Tag (when used with a locally defined tagged type)
-- Internal_Tag (when used with a locally defined tagged type)
-- Interface_Ancestor_Tagswith System
-- Interface_Ancestor_Tags
with System.Storage_Elements;

4
gcc/ada/debug.adb
View File

@ -814,7 +814,9 @@ package body Debug is
-- Documentation for gprbuild Debug Flags --
---------------------------------------------
-- dn Do not delete temporary files createed by gprbuild at the end
-- dm Display the maximum number of simultaneous compilations.
-- dn Do not delete temporary files created by gprbuild at the end
-- of execution, such as temporary config pragma files, mapping
-- files or project path files.

33
gcc/ada/exp_prag.adb
View File

@ -990,8 +990,8 @@ package body Exp_Prag is
-- Case where we generate a direct raise
if ((Debug_Flag_Dot_G or else
Restriction_Active (No_Exception_Propagation))
if ((Debug_Flag_Dot_G
or else Restriction_Active (No_Exception_Propagation))
and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
then
@ -1073,12 +1073,10 @@ package body Exp_Prag is
Rewrite (N,
Make_If_Statement (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd => Cond),
Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
Name =>
New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
Parameter_Associations => New_List (Relocate_Node (Msg))))));
end if;
@ -1146,15 +1144,13 @@ package body Exp_Prag is
Set_All_Upper_Case;
Psect :=
Make_String_Literal (Eloc,
Strval => String_From_Name_Buffer);
Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
else
Get_Name_String (Chars (Internal));
Set_All_Upper_Case;
Psect :=
Make_String_Literal (Iloc,
Strval => String_From_Name_Buffer);
Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
end if;
Ploc := Sloc (Psect);
@ -1173,7 +1169,6 @@ package body Exp_Prag is
Strval => "common_object")),
Make_Pragma_Argument_Association (Ploc,
Expression => New_Copy_Tree (Psect)))));
end Expand_Pragma_Common_Object;
---------------------------------------
@ -1298,17 +1293,17 @@ package body Exp_Prag is
-- Expand_Pragma_Import_Export_Exception --
-------------------------------------------
-- For a VMS exception fix up the language field with "VMS"
-- instead of "Ada" (gigi needs this), create a constant that will be the
-- value of the VMS condition code and stuff the Interface_Name field
-- with the unexpanded name of the exception (if not already set).
-- For a Ada exception, just stuff the Interface_Name field
-- with the unexpanded name of the exception (if not already set).
-- For a VMS exception fix up the language field with "VMS" instead of
-- "Ada" (gigi needs this), create a constant that will be the value of
-- the VMS condition code and stuff the Interface_Name field with the
-- unexpanded name of the exception (if not already set). For a Ada
-- exception, just stuff the Interface_Name field with the unexpanded
-- name of the exception (if not already set).
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
begin
-- This pragma is only effective on OpenVMS systems, it was ignored
-- on non-VMS systems, and we need to ignore it here as well.
-- This pragma is only effective on OpenVMS systems, it was ignored on
-- non-VMS systems, and we need to ignore it here as well.
if not OpenVMS_On_Target then
return;

44
gcc/ada/freeze.adb
View File

@ -3145,10 +3145,8 @@ package body Freeze is
if Present (ADC) and then Base_Type (Rec) = Rec then
if not (Placed_Component
or else
Present (SSO_ADC)
or else
Is_Packed (Rec))
or else Present (SSO_ADC)
or else Is_Packed (Rec))
then
-- Warn if clause has no effect when no component clause is
-- present, but suppress warning if the Bit_Order is required
@ -3296,8 +3294,7 @@ package body Freeze is
while Present (Comp) loop
if Present (Component_Clause (Comp))
and then (Is_Fixed_Point_Type (Etype (Comp))
or else
Is_Bit_Packed_Array (Etype (Comp)))
or else Is_Bit_Packed_Array (Etype (Comp)))
then
Check_Size
(Component_Name (Component_Clause (Comp)),
@ -4185,6 +4182,41 @@ package body Freeze is
Freeze_Subprogram (E);
end if;
-- If warning on suspicious contracts then check for the case of
-- a postcondition other than False for a No_Return subprogram.
if No_Return (E)
and then Warn_On_Suspicious_Contract
and then Present (Contract (E))
then
declare
Prag : Node_Id := Pre_Post_Conditions (Contract (E));
Exp : Node_Id;
begin
while Present (Prag) loop
if Nam_In (Pragma_Name (Prag), Name_Post,
Name_Postcondition,
Name_Refined_Post)
then
Exp :=
Expression
(First (Pragma_Argument_Associations (Prag)));
if Nkind (Exp) /= N_Identifier
or else Chars (Exp) /= Name_False
then
Error_Msg_NE
("useless postcondition, & is marked "
& "No_Return?T?", Exp, E);
end if;
end if;
Prag := Next_Pragma (Prag);
end loop;
end;
end if;
-- Here for other than a subprogram or type
else

17
gcc/ada/gnat_rm.texi
View File

@ -650,7 +650,6 @@ The GNAT Library
* GNAT.Wide_Wide_String_Split (g-zistsp.ads)::
* Interfaces.C.Extensions (i-cexten.ads)::
* Interfaces.C.Streams (i-cstrea.ads)::
* Interfaces.CPP (i-cpp.ads)::
* Interfaces.Packed_Decimal (i-pacdec.ads)::
* Interfaces.VxWorks (i-vxwork.ads)::
* Interfaces.VxWorks.IO (i-vxwoio.ads)::
@ -12138,9 +12137,7 @@ convention. Any declarations useful for interfacing to any language on
the given hardware architecture should be provided directly in
@code{Interfaces}.
@end cartouche
Followed. An additional package not defined
in the Ada Reference Manual is @code{Interfaces.CPP}, used
for interfacing to C++.
Followed.
@sp 1
@cartouche
@ -19015,7 +19012,6 @@ of GNAT, and will generate a warning message.
* GNAT.Wide_Wide_String_Split (g-zistsp.ads)::
* Interfaces.C.Extensions (i-cexten.ads)::
* Interfaces.C.Streams (i-cstrea.ads)::
* Interfaces.CPP (i-cpp.ads)::
* Interfaces.Packed_Decimal (i-pacdec.ads)::
* Interfaces.VxWorks (i-vxwork.ads)::
* Interfaces.VxWorks.IO (i-vxwoio.ads)::
@ -20463,17 +20459,6 @@ to C libraries.
This package is a binding for the most commonly used operations
on C streams.
@node Interfaces.CPP (i-cpp.ads)
@section @code{Interfaces.CPP} (@file{i-cpp.ads})
@cindex @code{Interfaces.CPP} (@file{i-cpp.ads})
@cindex C++ interfacing
@cindex Interfacing, to C++
@noindent
This package provides facilities for use in interfacing to C++. It
is primarily intended to be used in connection with automated tools
for the generation of C++ interfaces.
@node Interfaces.Packed_Decimal (i-pacdec.ads)
@section @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads})
@cindex @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads})

8
gcc/ada/gnat_ugn.texi
View File

@ -19872,10 +19872,16 @@ Specifies the default behavior of generated skeletons. @var{val} can be either
"fail" or "pass", "fail" being the default.
@item --passed-tests=@var{val}
@cindex @option{--skeleton-default} (@command{gnattest})
@cindex @option{--passed-tests} (@command{gnattest})
Specifies whether or not passed tests should be shown. @var{val} can be either
"show" or "hide", "show" being the default.
@item --exit-status=@var{val}
@cindex @option{--exit-status} (@command{gnattest})
Specifies whether or not generated test driver should return failure exit
status if at least one test fails or crashes. @var{val} can be either
"on" or "off", "off" being the default.
@item --tests-root=@var{dirname}
@cindex @option{--tests-root} (@command{gnattest})

35
gcc/ada/i-cpp.adb
View File

@ -1,35 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- I N T E R F A C E S . C P P --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Dummy body to deal with bootstrap issues (there used to be a real body)
package body Interfaces.CPP is
end Interfaces.CPP;

50
gcc/ada/i-cpp.ads
View File

@ -1,50 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- I N T E R F A C E S . C P P --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Missing package comment ???
with Ada.Tags;
package Interfaces.CPP is
pragma Elaborate_Body;
-- We have a dummy body to deal with bootstrap path issues
subtype Vtable_Ptr is Ada.Tags.Tag;
-- These need commenting (this is not an RM package) ???
function Expanded_Name (T : Vtable_Ptr) return String
renames Ada.Tags.Expanded_Name;
function External_Tag (T : Vtable_Ptr) return String
renames Ada.Tags.External_Tag;
end Interfaces.CPP;

1
gcc/ada/impunit.adb
View File

@ -345,7 +345,6 @@ package body Impunit is
("i-cexten", F), -- Interfaces.C.Extensions
("i-cil ", F), -- Interfaces.CIL
("i-cilobj", F), -- Interfaces.CIL.Object
("i-cpp ", F), -- Interfaces.CPP
("i-cstrea", F), -- Interfaces.C.Streams
("i-java ", F), -- Interfaces.Java
("i-javjni", F), -- Interfaces.Java.JNI

6
gcc/ada/rtsfind.ads
View File

@ -71,7 +71,8 @@ package Rtsfind is
-- of Ada.Wide_Wide_Text_IO.
-- Names of the form Interfaces_xxx are first level children of
-- Interfaces_CPP refers to package Interfaces.CPP
-- Interfaces. For example, the name Interfaces_Packed_Decimal refers to
-- package Interfaces.Packed_Decimal.
-- Names of the form System_xxx are first level children of System, whose
-- name is System.xxx. For example, the name System_Str_Concat refers to
@ -202,7 +203,6 @@ package Rtsfind is
-- Children of Interfaces
Interfaces_CPP,
Interfaces_Packed_Decimal,
-- Package System
@ -466,7 +466,7 @@ package Rtsfind is
Ada_Wide_Wide_Text_IO_Modular_IO;
subtype Interfaces_Child is RTU_Id
range Interfaces_CPP .. Interfaces_Packed_Decimal;
range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal;
-- Range of values for children of Interfaces
subtype System_Child is RTU_Id

8
gcc/ada/s-tassta.adb
View File

@ -545,8 +545,8 @@ package body System.Tasking.Stages is
else
-- When the application code says nothing about the task affinity
-- (task without CPU aspect) then the compiler inserts the
-- Unspecified_CPU value which indicates to the run-time library that
-- (task without CPU aspect) then the compiler inserts the value
-- Unspecified_CPU which indicates to the run-time library that
-- the task will activate and execute on the same processor as its
-- activating task if the activating task is assigned a processor
-- (RM D.16(14/3)).
@ -557,8 +557,8 @@ package body System.Tasking.Stages is
else System.Multiprocessors.CPU_Range (CPU));
end if;
-- Find parent P of new Task, via master level number. Independent tasks
-- should have Parent = Environment_Task, and all tasks created
-- Find parent P of new Task, via master level number. Independent
-- tasks should have Parent = Environment_Task, and all tasks created
-- by independent tasks are also independent. See, for example,
-- s-interr.adb, where Interrupt_Manager does "new Server_Task". The
-- access type is at library level, so the parent of the Server_Task

6
gcc/ada/s-tasuti.adb
View File

@ -477,8 +477,7 @@ package body System.Tasking.Utilities is
(Self_ID, "Make_Passive: Phase 1, parent waiting", 'M'));
-- If parent is in Master_Completion_Sleep, it cannot be on a
-- terminate alternative, hence it cannot have Wait_Count of
-- zero.
-- terminate alternative, hence it cannot have Wait_Count of zero.
pragma Assert (P.Common.Wait_Count > 0);
P.Common.Wait_Count := P.Common.Wait_Count - 1;
@ -489,8 +488,7 @@ package body System.Tasking.Utilities is
else
pragma Debug
(Debug.Trace
(Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
(Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M'));
null;
end if;

6
gcc/ada/sem_prag.adb
View File

@ -5258,9 +5258,7 @@ package body Sem_Prag is
-- The copy is needed because the pragma is expanded into other
-- constructs which are not acceptable in the N_Contract node.
if Acts_As_Spec (PO)
and then GNATprove_Mode
then
if Acts_As_Spec (PO) and then GNATprove_Mode then
declare
Prag : constant Node_Id := New_Copy_Tree (N);
@ -5269,7 +5267,7 @@ package body Sem_Prag is
Preanalyze_Assert_Expression
(Get_Pragma_Arg
(First (Pragma_Argument_Associations (Prag))),
(First (Pragma_Argument_Associations (Prag))),
Standard_Boolean);
-- Preanalyze the corresponding aspect (if any)

88
gcc/ada/sprint.adb
View File

@ -58,6 +58,10 @@ package body Sprint is
-- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
-- value. The call clears it back to Empty.
First_Debug_Sloc : Source_Ptr;
-- Sloc of first byte of the current output file if we are generating a
-- source debug file.
Debug_Sloc : Source_Ptr;
-- Sloc of first byte of line currently being written if we are
-- generating a source debug file.
@ -512,7 +516,38 @@ package body Sprint is
procedure Set_Debug_Sloc is
begin
if Debug_Generated_Code and then Present (Dump_Node) then
Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
declare
Loc : constant Source_Ptr := Sloc (Dump_Node);
begin
-- Do not change the location of nodes defined in package Standard
-- and nodes of pragmas scanned by Targparm.
if Loc <= Standard_Location then
null;
-- Update the location of a node which is part of the current .dg
-- output. This situation occurs in comma separated parameter
-- declarations since each parameter references the same parameter
-- type node (ie. obj1, obj2 : <param-type>).
-- Note: This case is needed here since we cannot use the routine
-- In_Extended_Main_Code_Unit with nodes whose location is a .dg
-- file.
elsif Loc >= First_Debug_Sloc then
Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
-- Do not change the location of nodes which are not part of the
-- generated code
elsif not In_Extended_Main_Code_Unit (Loc) then
null;
else
Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
end if;
end;
-- We do not know the actual end location in the generated code and
-- it could be much closer than in the source code, so play safe.
@ -581,6 +616,7 @@ package body Sprint is
Debug_Flag_G := False;
Debug_Flag_O := False;
Debug_Flag_S := False;
First_Debug_Sloc := No_Location;
-- Dump requested units
@ -598,6 +634,7 @@ package body Sprint is
if Debug_Generated_Code then
Set_Special_Output (Print_Debug_Line'Access);
Create_Debug_Source (Source_Index (U), Debug_Sloc);
First_Debug_Sloc := Debug_Sloc;
Write_Source_Line (1);
Last_Line_Printed := 1;
Sprint_Node (Cunit (U));
@ -1358,10 +1395,55 @@ package body Sprint is
Sprint_Node (Component_Definition (Node));
-- A contract node should not appear in the tree. It is a semantic
-- node attached to entry and [generic] subprogram entities.
-- node attached to entry and [generic] subprogram entities. But we
-- still provide meaningful output, in case called from the debugger.
when N_Contract =>
raise Program_Error;
declare
P : Node_Id;
begin
Indent_Begin;
Write_Str ("N_Contract node");
Write_Eol;
Write_Indent_Str ("Pre_Post_Conditions");
Indent_Begin;
P := Pre_Post_Conditions (Node);
while Present (P) loop
Sprint_Node (P);
P := Next_Pragma (P);
end loop;
Write_Eol;
Indent_End;
Write_Indent_Str ("Contract_Test_Cases");
Indent_Begin;
P := Contract_Test_Cases (Node);
while Present (P) loop
Sprint_Node (P);
P := Next_Pragma (P);
end loop;
Write_Eol;
Indent_End;
Write_Indent_Str ("Classifications");
Indent_Begin;
P := Classifications (Node);
while Present (P) loop
Sprint_Node (P);
P := Next_Pragma (P);
end loop;
Write_Eol;
Indent_End;
Indent_End;
end;
when N_Decimal_Fixed_Point_Definition =>
Write_Str_With_Col_Check_Sloc (" delta ");