+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
i-cexten$(objext) \
i-cobol$(objext) \
i-cpoint$(objext) \
- i-cpp$(objext) \
i-cstrea$(objext) \
i-cstrin$(objext) \
i-fortra$(objext) \
-- 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).
-- 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;
-- 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.
-- 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
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;
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);
Strval => "common_object")),
Make_Pragma_Argument_Association (Ploc,
Expression => New_Copy_Tree (Psect)))));
-
end Expand_Pragma_Common_Object;
---------------------------------------
-- 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;
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
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)),
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
* 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)::
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
* 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)::
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})
"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})
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
("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
-- 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
-- Children of Interfaces
- Interfaces_CPP,
Interfaces_Packed_Decimal,
-- Package System
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
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)).
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
(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;
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;
-- 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);
Preanalyze_Assert_Expression
(Get_Pragma_Arg
- (First (Pragma_Argument_Associations (Prag))),
+ (First (Pragma_Argument_Associations (Prag))),
Standard_Boolean);
-- Preanalyze the corresponding aspect (if any)
-- 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.
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.
Debug_Flag_G := False;
Debug_Flag_O := False;
Debug_Flag_S := False;
+ First_Debug_Sloc := No_Location;
-- Dump requested units
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));
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 ");
projects / platform / upstream / gcc.git / commitdiff