+2017-09-08 Bob Duff <duff@adacore.com>
+
+PR ada/80888
+ * a-textio.adb, a-witeio.adb, a-ztexio.adb (Set_WCEM): Use
+ Default_WCEM by default (i.e. if the encoding is not specified
+ by the Form string).
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * s-trasym.ads (Hexa_Traceback): If
+ Suppress_Hex is True, print "..." instead of a hexadecimal
+ address.
+ * s-trasym.adb: Ignore No_Hex in this version.
+ Misc cleanup.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * debug.adb: Minor reformatting.
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * a-cbdlli.adb, a-cohama.adb, a-cohase.adb (Copy): Rewrite the
+ code so it doesn't trigger an "uninit var" warning.
+
+2017-09-08 Nicolas Roche <roche@adacore.com>
+
+ * s-hibaen.ads: Remove obsolete file.
+
+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * a-locale.ads: Add comment explaining the state of this package.
+
+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Is_CCT_Instance): Allow calls in the context
+ of packages.
+ * sem_prag.ads, sem_prag.adb (Find_Related_Declaration_Or_Body):
+ allow calls in the context of package spec (for pragma
+ Initializes) and bodies (for pragma Refined_State).
+
+2017-09-08 Bob Duff <duff@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Copy the Do_Range_Check flag to the
+ new Exp.
+
2017-09-08 Eric Botcazou <ebotcazou@adacore.com>
* debug.adb (dA): Adjust comment.
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2017, 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- --
C : Count_Type;
begin
- if Capacity = 0 then
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
+
C := Source.Length;
- elsif Capacity >= Source.Length then
+ else
C := Capacity;
- elsif Checks then
- raise Capacity_Error with "Capacity value too small";
end if;
return Target : List (Capacity => C) do
is
New_Item : Element_Type;
pragma Unmodified (New_Item);
- -- OK to reference, see below
+ -- OK to reference, see below. Needed to suppress front end warning.
begin
-- There is no explicit element provided, but in an instance the element
-- initialization, so insert the specified number of possibly
-- initialized elements at the given position.
+ pragma Warnings (Off); -- Needed to suppress back end warning
Insert (Container, Before, New_Item, Position, Count);
+ pragma Warnings (On);
end Insert;
---------------------
C : Count_Type;
begin
- if Capacity = 0 then
- C := Source.Length;
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
- elsif Capacity >= Source.Length then
+ C := Source.Length;
+ else
C := Capacity;
-
- elsif Checks then
- raise Capacity_Error
- with "Requested capacity is less than Source length";
end if;
return Target : Map do
C : Count_Type;
begin
- if Capacity = 0 then
- C := Source.Length;
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
- elsif Capacity >= Source.Length then
+ C := Source.Length;
+ else
C := Capacity;
-
- elsif Checks then
- raise Capacity_Error
- with "Requested capacity is less than Source length";
end if;
return Target : Set do
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- --
------------------------------------------------------------------------------
+-- Note that this package is currently not implemented on any platform and
+-- functions Language and Country will always return
+-- Language_Unknown/Country_Unknown.
+
package Ada.Locales is
pragma Preelaborate (Locales);
pragma Remote_Types (Locales);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
(Source : String;
Side : Trim_End) return String
is
- Low, High : Integer;
-
begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks case
-
- if Low = 0 then
- return "";
-
- -- At least one non-blank
+ case Side is
+ when Strings.Left =>
+ declare
+ Low : constant Natural := Index_Non_Blank (Source, Forward);
+ begin
+ -- All blanks case
- else
- High := Index_Non_Blank (Source, Backward);
+ if Low = 0 then
+ return "";
+ end if;
- case Side is
- when Strings.Left =>
declare
subtype Result_Type is String (1 .. Source'Last - Low + 1);
-
begin
return Result_Type (Source (Low .. Source'Last));
end;
+ end;
+
+ when Strings.Right =>
+ declare
+ High : constant Natural := Index_Non_Blank (Source, Backward);
+ begin
+ -- All blanks case
+
+ if High = 0 then
+ return "";
+ end if;
- when Strings.Right =>
declare
subtype Result_Type is String (1 .. High - Source'First + 1);
-
begin
return Result_Type (Source (Source'First .. High));
end;
+ end;
+
+ when Strings.Both =>
+ declare
+ Low : constant Natural := Index_Non_Blank (Source, Forward);
+ begin
+ -- All blanks case
+
+ if Low = 0 then
+ return "";
+ end if;
- when Strings.Both =>
declare
+ High : constant Natural :=
+ Index_Non_Blank (Source, Backward);
subtype Result_Type is String (1 .. High - Low + 1);
-
begin
return Result_Type (Source (Low .. High));
end;
- end case;
- end if;
+ end;
+ end case;
end Trim;
procedure Trim
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- This package contains the search functions from Ada.Strings.Fixed. They
-- are separated out because they are shared by Ada.Strings.Bounded and
--- Ada.Strings.Unbounded, and we don't want to drag other irrelevant stuff
--- from Ada.Strings.Fixed when using the other two packages. We make this
--- a private package, since user programs should access these subprograms
--- via one of the standard string packages.
+-- Ada.Strings.Unbounded, and we don't want to drag in other irrelevant stuff
+-- from Ada.Strings.Fixed when using the other two packages. We make this a
+-- private package, since user programs should access these subprograms via
+-- one of the standard string packages.
with Ada.Strings.Maps;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- This package contains the search functions from Ada.Strings.Wide_Fixed.
-- They are separated out because they are shared by Ada.Strings.Wide_Bounded
--- and Ada.Strings.Wide_Unbounded, and we don't want to drag other irrelevant
--- stuff from Ada.Strings.Wide_Fixed when using the other two packages. We
--- make this a private package, since user programs should access these
--- subprograms via one of the standard string packages.
+-- and Ada.Strings.Wide_Unbounded, and we don't want to drag in other
+-- irrelevant stuff from Ada.Strings.Wide_Fixed when using the other two
+-- packages. We make this a private package, since user programs should
+-- access these subprograms via one of the standard string packages.
with Ada.Strings.Wide_Maps;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- This package contains search functions from Ada.Strings.Wide_Wide_Fixed.
-- They are separated because Ada.Strings.Wide_Wide_Bounded shares these
--- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want
--- to drag other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using
--- the other two packages. We make this a private package, since user
--- programs should access these subprograms via one of the standard string
--- packages.
+-- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want to
+-- drag in other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using
+-- the other two packages. We make this a private package, since user programs
+-- should access these subprograms via one of the standard string packages.
with Ada.Strings.Wide_Wide_Maps;
Num_Chosen : Nat;
-- Number of units chosen in the elaboration order so far
+ Diagnose_Elaboration_Problem_Called : Boolean := False;
+ -- True if Diagnose_Elaboration_Problem was called. Used in an assertion.
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
- Illegal_Elab_All : Boolean := False;
- -- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
- -- (explicit or implicit).
+ Elab_Cycle_Found : Boolean := False;
+ -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma
+ -- Elaborate_All, explicit or implicit).
function SCC (U : Unit_Id) return Unit_Id;
-- The root of the strongly connected component containing U
if No_Pred = Chosen then
No_Pred := UNR.Table (Chosen).Nextnp;
-
else
- -- Note that we just ignore the situation where it does not
- -- appear in the No_Pred list, this happens in calls from the
- -- Diagnose_Elaboration_Problem routine, where cycles are being
- -- removed arbitrarily from the graph.
-
U := No_Pred;
while U /= No_Unit_Id loop
if UNR.Table (U).Nextnp = Chosen then
UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
- exit;
+ goto Done_Removal;
end if;
U := UNR.Table (U).Nextnp;
end loop;
+
+ -- Here if we didn't find it on the No_Pred list. This can happen
+ -- only in calls from the Diagnose_Elaboration_Problem routine,
+ -- where cycles are being removed arbitrarily from the graph.
+
+ pragma Assert (Errors_Detected > 0);
+ <<Done_Removal>> null;
end if;
-- For all successors, decrement the number of predecessors, and if it
-- Start of processing for Diagnose_Elaboration_Problem
begin
+ Diagnose_Elaboration_Problem_Called := True;
Set_Standard_Error;
-- Output state of things if debug flag N set
begin
Write_Eol;
Write_Eol;
- Write_Str ("Diagnose_Elaboration_Problem called");
- Write_Eol;
- Write_Str ("List of remaining unchosen units and predecessors");
- Write_Eol;
+ Write_Line ("Diagnose_Elaboration_Problem called");
+ Write_Line ("List of remaining unchosen units and predecessors");
for U in Units.First .. Units.Last loop
if UNR.Table (U).Elab_Position = 0 then
Write_Unit_Name (Units.Table (U).Uname);
Write_Str (" (Num_Pred = ");
Write_Int (NP);
- Write_Char (')');
- Write_Eol;
+ Write_Line (")");
if NP = 0 then
if Units.Table (U).Elaborate_Body then
- Write_Str
+ Write_Line
(" (not chosen because of Elaborate_Body)");
- Write_Eol;
else
- Write_Str (" ****************** why not chosen?");
- Write_Eol;
+ Write_Line (" ****************** why not chosen?");
end if;
end if;
end loop;
if NP /= 0 then
- Write_Str (" **************** Num_Pred value wrong!");
- Write_Eol;
+ Write_Line (" **************** Num_Pred value wrong!");
end if;
end if;
end loop;
or Pessimistic_Elab_Order
or Debug_Flag_Old
or Debug_Flag_Older
- or Illegal_Elab_All
+ or Elab_Cycle_Found
then
if Debug_Flag_V then
Write_Line ("Doing old...");
Elab_Old.Find_Elab_Order (Old_Elab_Order);
end if;
+ pragma Assert (Elab_Cycle_Found <= -- implies
+ Diagnose_Elaboration_Problem_Called);
+
declare
Old_Order : Unit_Id_Array renames
Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
if not Zero_Formatting then
Write_Eol;
- Write_Str ("REFERENCED SOURCES");
- Write_Eol;
+ Write_Line ("REFERENCED SOURCES");
end if;
for J in reverse Order'Range loop
Write_Str (" ");
end if;
- Write_Str (Get_Name_String (Source));
- Write_Eol;
+ Write_Line (Get_Name_String (Source));
end if;
end loop;
Write_Str (" ");
end if;
- Write_Str (Get_Name_String (Source));
- Write_Eol;
+ Write_Line (Get_Name_String (Source));
end if;
end loop;
begin
if not Zero_Formatting then
Write_Eol;
- Write_Str (" ELABORATION ORDER DEPENDENCIES");
- Write_Eol;
+ Write_Line (" ELABORATION ORDER DEPENDENCIES");
Write_Eol;
end if;
begin
if Title /= "" then
Write_Eol;
- Write_Str (Title);
- Write_Eol;
+ Write_Line (Title);
end if;
for J in Order'Range loop
Write_Unit_Name (Units.Table (Root).Uname);
Write_Str (" -- ");
Write_Int (Nodes'Length);
- Write_Str (" units:");
- Write_Eol;
+ Write_Line (" units:");
for J in Nodes'Range loop
Write_Str (" ");
or else Withs.Table (W).Elab_All_Desirable
then
if SCC (U) = SCC (Withed_Unit) then
- Illegal_Elab_All := True; -- ????
+ Elab_Cycle_Found := True; -- ???
-- We could probably give better error messages
-- than Elab_Old here, but for now, to avoid
-- disruption, we don't give any error here.
- -- Instead, we set the Illegal_Elab_All flag above,
+ -- Instead, we set the Elab_Cycle_Found flag above,
-- and then run the Elab_Old algorithm to issue the
-- error message. Ideally, we would like to print
-- multiple errors rather than stopping after the
-- nodes have been chosen.
Outer : loop
+ if Debug_Flag_N then
+ Write_Line ("Outer loop");
+ end if;
-- If there are no nodes with predecessors, then either we are
-- done, as indicated by Num_Left being set to zero, or we have
and then Better_Choice (U, Best_So_Far)
then
if Debug_Flag_N then
- Write_Str (" tentatively chosen (best so far)");
- Write_Eol;
+ Write_Line (" tentatively chosen (best so far)");
end if;
Best_So_Far := U;
+ else
+ if Debug_Flag_N then
+ Write_Line (" SCC not ready");
+ end if;
end if;
U := UNR.Table (U).Nextnp;
exit No_Pred_Search when U = No_Unit_Id;
end loop No_Pred_Search;
+ -- If there are no units on the No_Pred list whose SCC is ready,
+ -- there must be a cycle. Defer to Elab_Old to print an error
+ -- message.
+
+ if Best_So_Far = No_Unit_Id then
+ Elab_Cycle_Found := True;
+ return;
+ end if;
+
-- Choose the best candidate found
Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
if Better_Choice (U, Best_So_Far) then
if Debug_Flag_N then
- Write_Str (" tentatively chosen (best so far)");
- Write_Eol;
+ Write_Line (" tentatively chosen (best so far)");
end if;
Best_So_Far := U;
Suppress => Validity_Check);
Set_Validated_Object (Var_Id, New_Copy_Tree (Exp));
-
Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc));
PV := New_Occurrence_Of (Var_Id, Loc);
+ -- Copy the Do_Range_Check flag over to the new Exp, so it doesn't
+ -- get lost. Floating point types are handled elsewhere.
+
+ if not Is_Floating_Point_Type (Typ) then
+ Set_Do_Range_Check (Exp, Do_Range_Check (Original_Node (Exp)));
+ end if;
+
-- Otherwise the expression does not denote a variable. Force its
-- evaluation by capturing its value in a constant. Generate:
-- calls a procedure in another package, the static elaboration
-- machinery adds an implicit Elaborate_All on the other package. This
-- switch disables the addition of the implicit pragma in such cases.
- --
+
-- d.z Restore previous front-end support for Inline_Always. In default
-- mode, for targets that use the GCC back end, Inline_Always is
-- handled by the back end. Use of this switch restores the previous
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2010, AdaCore --
+-- Copyright (C) 2000-2017, AdaCore --
-- --
-- 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- --
-- which has the same effect as passing a pointer.
-- This type is not private because keeping it by reference would require
- -- defining it in a way (e.g a tagged type) that would drag other run time
- -- files, which is unwanted in the case of e.g ravenscar where we want to
- -- minimize the number of run time files needed by default.
+ -- defining it in a way (e.g. using a tagged type) that would drag in other
+ -- run-time files, which is unwanted in the case of e.g. Ravenscar where we
+ -- want to minimize the number of run-time files needed by default.
CE : constant Exception_Type; -- Constraint_Error
PE : constant Exception_Type; -- Program_Error
if Main_Source_File /= No_Source_File then
Version := Source_Checksum (Main_Source_File);
+ else
+ Error_Msg_File_1 := Fname;
+ Error_Msg ("file{ not found", Load_Msg_Sloc);
end if;
Units.Table (Main_Unit) :=
and then Get_Scope_Num (Ref.Ent_Scope) /= No_Scope
and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope
+
+ -- Discard references to loop parameters introduced within
+ -- expression functions, as they give two references: one from
+ -- the analysis of the expression function itself and one from
+ -- the analysis of the expanded body. We don't lose any globals
+ -- by discarding them, because such loop parameters can only be
+ -- accessed locally from within the expression function body.
+
+ and then not
+ (Ekind (Ref.Ent) = E_Loop_Parameter
+ and then Scope_Within
+ (Ref.Ent, Unique_Entity (Ref.Ref_Scope))
+ and then Is_Expression_Function (Ref.Ref_Scope))
then
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Index;
----------------------
procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
-
procedure Compute_Max_Length
(Ent : Entity_Id;
Starting_Position : Uint := Uint_0;
Starting_First_Bit : Uint := Uint_0;
Prefix_Length : Natural := 0)
is
- Comp : Entity_Id;
+ Comp : Entity_Id;
begin
Comp := First_Component_Or_Discriminant (Ent);
Fbit : Uint;
Spos : Uint;
Sbit : Uint;
+
Name_Length : Natural;
+
begin
Get_Decoded_Name_String (Chars (Comp));
Name_Length := Prefix_Length + Name_Len;
Spos := Starting_Position + Npos;
Sbit := Starting_First_Bit + Fbit;
+
if Sbit >= SSU then
Spos := Spos + 1;
Sbit := Sbit - SSU;
Starting_First_Bit : Uint := Uint_0;
Prefix : String := "")
is
- Comp : Entity_Id;
+ Comp : Entity_Id;
begin
Comp := First_Component_Or_Discriminant (Ent);
then
Spos := Starting_Position + Npos;
Sbit := Starting_First_Bit + Fbit;
+
if Sbit >= SSU then
Spos := Spos + 1;
Sbit := Sbit - SSU;
end if;
+
List_Record_Layout (Ctyp,
Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & ".");
+
goto Continue;
end if;
if Known_Static_Normalized_Position (Comp) then
Spos := Starting_Position + Npos;
Sbit := Starting_First_Bit + Fbit;
+
if Sbit >= SSU then
Spos := Spos + 1;
end if;
+
UI_Image (Spos);
Spaces (Max_Spos_Length - UI_Image_Length);
Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
then
Spaces (Max_Spos_Length - 2);
Write_Str ("bit offset");
+
if Starting_Position /= Uint_0
or else Starting_First_Bit /= Uint_0
then
UI_Write (Starting_Position * SSU + Starting_First_Bit);
Write_Str (" +");
end if;
+
Write_Val (Bofs, Paren => True);
Write_Str (" size in bits = ");
Write_Val (Esiz, Paren => True);
Write_Eol;
+
goto Continue;
elsif Known_Normalized_Position (Comp)
and then List_Representation_Info = 3
then
Spaces (Max_Spos_Length - 2);
+
if Starting_Position /= Uint_0 then
Write_Char (' ');
UI_Write (Starting_Position);
Write_Str (" +");
end if;
+
Write_Val (Npos);
else
Write_Str (" range ");
Sbit := Starting_First_Bit + Fbit;
+
if Sbit >= SSU then
Sbit := Sbit - SSU;
end if;
+
UI_Write (Sbit);
Write_Str (" .. ");
end loop;
end List_Record_Layout;
+ -- Start of processing for List_Record_Info
+
begin
Blank_Line;
List_Type_Info (Ent);
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . H I E _ B A C K _ E N D --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-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. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides an interface used in HI-E mode to determine
--- whether or not the back end can handle certain constructs in a manner
--- that is consistent with certification requirements.
-
--- The approach is to define entities which may or may not be present in
--- a HI-E configured library. If the entity is present then the compiler
--- operating in HI-E mode will allow the corresponding operation. If the
--- entity is not present, the corresponding construct will be flagged as
--- not permitted in High Integrity mode.
-
--- The default version of this unit delivered with the HI-E compiler is
--- configured in a manner appropriate for the target, but it is possible
--- to reconfigure the run-time to change the settings as required.
-
--- This unit is not used and never accessed by the compiler unless it is
--- operating in HI-E mode, so the settings are irrelevant. However, we
--- do include a standard version with all entities present in the standard
--- run-time for use when pragma No_Run_Time is specified.
-
-package System.HIE_Back_End is
-
- type Dummy is null record;
- pragma Suppress_Initialization (Dummy);
- -- This is the type used for the entities below. No properties of this
- -- type are ever referenced, and in particular, the entities are defined
- -- as variables, but their values are never referenced
-
- HIE_64_Bit_Divides : Dummy;
- -- This entity controls whether the front end allows 64-bit integer
- -- divide operations, including the case where division of 32-bit
- -- fixed-point operands requires 64-bit arithmetic. This can safely
- -- be set as High_Integrity on 64-bit machines which provide this
- -- operation as a native instruction, but on most 32-bit machines
- -- a run time call (e.g. to __divdi3 in gcclib) is required. If a
- -- certifiable version of this routine is available, then setting
- -- this entity to High_Integrity with a pragma will cause appropriate
- -- calls to be generated, allowing 64-bit integer division operations.
-
- HIE_Long_Shifts : Dummy;
- -- This entity controls whether the front end allows generation of
- -- long shift instructions, i.e. shifts that operate on 64-bit values.
- -- Such shifts are required for the implementation of fixed-point
- -- types longer than 32 bits. This can safely be set as High_Integrity
- -- on 64-bit machines that provide this operation at the hardware level,
- -- but on some 32-bit machines a run time call is required. If there
- -- is a certifiable version available of the relevant run-time routines,
- -- then setting this entity to High_Integrity with a pragma will cause
- -- appropriate calls to be generated, allowing the declaration and use
- -- of fixed-point types longer than 32 bits.
-
- HIE_Aggregates : Dummy;
- -- In the general case, the use of aggregates may generate calls
- -- to run-time routines in the C library, including memset, memcpy,
- -- memmove, and bcopy. This entity can be set to High_Integrity with
- -- a pragma if certifiable versions of all these routines are available,
- -- in which case aggregates are permitted in HI-E mode. Otherwise the
- -- HI-E compiler will reject any use of aggregates.
-
- HIE_Composite_Assignments : Dummy;
- -- The assignment of composite objects other than small records and
- -- arrays whose size is 64-bits or less and is set by an explicit
- -- size clause may generate calls to memcpy, memmove, and bcopy.
- -- If certifiable versions of all these routines are available, then
- -- this entity may be set to High_Integrity using a pragma, in which
- -- case such assignments are permitted. Otherwise the HI-E compiler
- -- will reject any such composite assignments.
-
-end System.HIE_Back_End;
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2017, 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- --
-- which has the same effect as passing a pointer.
-- This type is not private because keeping it by reference would require
- -- defining it in a way (e.g a tagged type) that would drag other run time
- -- files, which is unwanted in the case of e.g ravenscar where we want to
- -- minimize the number of run time files needed by default.
+ -- defining it in a way (e.g. using a tagged type) that would drag in other
+ -- run-time files, which is unwanted in the case of e.g. Ravenscar, where
+ -- we want to minimize the number of run-time files needed by default.
CE : constant Exception_Type; -- Constraint_Error
PE : constant Exception_Type; -- Program_Error
package body System.Traceback.Symbolic is
+ -- Note that Suppress_Hex is ignored in this version of this package.
+
------------------------
-- Symbolic_Traceback --
------------------------
begin
for J in Traceback'Range loop
Img := System.Address_Image (Traceback (J));
- Result (Last + 1 .. Last + 2) := "0x";
- Last := Last + 2;
+ Result (Last + 1 .. Last + 2) := "0x";
+ Last := Last + 2;
Result (Last + 1 .. Last + Img'Length) := Img;
- Last := Last + Img'Length + 1;
- Result (Last) := ' ';
+ Last := Last + Img'Length + 1;
+ Result (Last) := ' ';
end loop;
Result (Last) := ASCII.LF;
end if;
end Symbolic_Traceback;
+ -- "No_Hex" is ignored in this version, because otherwise we have nothing
+ -- at all to print.
+
+ function Symbolic_Traceback_No_Hex
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+ begin
+ return Symbolic_Traceback (Traceback);
+ end Symbolic_Traceback_No_Hex;
+
function Symbolic_Traceback
(E : Ada.Exceptions.Exception_Occurrence) return String
is
return Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E));
end Symbolic_Traceback;
+ function Symbolic_Traceback_No_Hex
+ (E : Ada.Exceptions.Exception_Occurrence) return String is
+ begin
+ return Symbolic_Traceback (E);
+ end Symbolic_Traceback_No_Hex;
+
------------------
-- Enable_Cache --
------------------
-- Run-time symbolic traceback support
--- The routines provided in this package assume that your application has
--- been compiled with debugging information turned on, since this information
--- is used to build a symbolic traceback.
+-- The routines provided in this package assume that your application has been
+-- compiled with debugging information turned on, since this information is
+-- used to build a symbolic traceback.
-- If you want to retrieve tracebacks from exception occurrences, it is also
-- necessary to invoke the binder with -E switch. Please refer to the gnatbind
-- documentation for more information.
-- Note that it is also possible (and often recommended) to compute symbolic
--- traceback outside the program execution, which in addition allows you
--- to distribute the executable with no debug info:
+-- traceback outside the program execution, which in addition allows you to
+-- distribute the executable with no debug info:
--
--- - build your executable with debug info
--- - archive this executable
--- - strip a copy of the executable and distribute/deploy this version
--- - at run time, compute absolute traceback (-bargs -E) from your
--- executable and log it using Ada.Exceptions.Exception_Information
--- - off line, compute the symbolic traceback using the executable archived
--- with debug info and addr2line or gdb (using info line *<addr>) on the
--- absolute addresses logged by your application.
+-- - build your executable with debug info
+-- - archive this executable
+-- - strip a copy of the executable and distribute/deploy this version
+-- - at run time, compute absolute traceback (-bargs -E) from your
+-- executable and log it using Ada.Exceptions.Exception_Information
+-- - off line, compute the symbolic traceback using the executable archived
+--
with debug info and addr2line or gdb (using info line *<addr>) on the
+-- absolute addresses logged by your application.
-- In order to retrieve symbolic information, functions in this package will
-- read on disk all the debug information of the executable file (found via
-- OS facilities, and load them in memory, causing a significant cpu and
-- memory overhead.
--- On platforms where the full capability is not supported, function
--- Symbolic_Traceback return a list of addresses expressed as "0x..."
--- separated by line feed.
-
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we can get
-- elaboration circularities when polling is turned on.
function Symbolic_Traceback
(Traceback : System.Traceback_Entries.Tracebacks_Array) return String;
- -- Build a string containing a symbolic traceback of the given call chain.
- -- Note: This procedure may be installed by Set_Trace_Decorator, to get a
- -- symbolic traceback on all exceptions raised (see
+ function Symbolic_Traceback_No_Hex
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String;
+ -- Build a string containing a symbolic traceback of the given call
+ -- chain. Note: These procedures may be installed by Set_Trace_Decorator,
+ -- to get a symbolic traceback on all exceptions raised (see
-- System.Exception_Traces).
function Symbolic_Traceback
(E : Ada.Exceptions.Exception_Occurrence) return String;
+ function Symbolic_Traceback_No_Hex
+ (E : Ada.Exceptions.Exception_Occurrence) return String;
-- Build string containing symbolic traceback of given exception occurrence
+ -- In the above, _No_Hex means do not print any hexadecimal addresses, even
+ -- if the symbol is not available. This is useful for getting deterministic
+ -- output from tests.
+
procedure Enable_Cache (Include_Modules : Boolean := False);
-- Read symbolic information from binary files and cache them in memory.
- -- This will speed up the above functions but will require more memory.
- -- If Include_Modules is true, shared modules (or DLL) will also be cached.
+ -- This will speed up the above functions but will require more memory. If
+ -- Include_Modules is true, shared modules (or DLL) will also be cached.
-- This procedure may do nothing if not supported. The profile of this
- -- subprogram may change in the future (new parameters can be added with
- -- default value), but backward compatibility for direct calls is
- -- supported.
+ -- subprogram may change in the future (new parameters can be added
+ -- with default value), but backward compatibility for direct calls
+ -- is supported.
end System.Traceback.Symbolic;
-- We must duplicate the expression with semantic information to
-- inherit the decoration of global entities in generic instances.
+ -- Set the parent of the new node to be the parent of the original
+ -- to get the proper context, which is needed for complete error
+ -- reporting and for semantic analysis.
Dup_Expr := New_Copy_Tree (Expression (Return_Stmt));
+ Set_Parent (Dup_Expr, Return_Stmt);
-- Replace the defining identifier of iterators and loop param
-- specifications by a clone to ensure that the cloned expression
Look_For_Body : constant Boolean :=
Nam_In (Prag_Nam, Name_Refined_Depends,
Name_Refined_Global,
- Name_Refined_Post);
+ Name_Refined_Post,
+ Name_Refined_State);
-- Refinement pragmas must be associated with a subprogram body [stub]
-- Start of processing for Find_Related_Declaration_Or_Body
elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
return Parent (Context);
+ -- The pragma appears inside the declarative part of a package body
+
+ elsif Nkind (Context) = N_Package_Body then
+ return Context;
+
-- The pragma appears inside the declarative part of a subprogram body
elsif Nkind (Context) = N_Subprogram_Body then
elsif Nkind (Context) = N_Task_Body then
return Context;
+ -- The pragma appears inside the visible part of a package specification
+
+ elsif Nkind (Context) = N_Package_Specification then
+ return Parent (Context);
+
-- The pragma is a byproduct of aspect expansion, return the related
-- context of the original aspect. This case has a lower priority as
-- the above circuitry pinpoints precisely the related context.
-- Depends
-- Extensions_Visible
-- Global
+ -- Initializes
-- Max_Queue_Length
-- Post
-- Post_Class
-- Refined_Depends
-- Refined_Global
-- Refined_Post
+ -- Refined_State
-- Test_Case
-- Volatile_Function
-- as well as attributes 'Old and 'Result. Find the declaration of the
and then Entity (R) = Standard_True
and then
((Is_Entity_Name (L) and then Is_Object (Entity (L)))
- or else
- Nkind (L) in N_Op)
+ or else
+ Nkind (L) in N_Op)
then
Error_Msg_N -- CODEFIX
("?r?comparison with True is redundant!", N);
if Is_Single_Task_Object (Context_Id) then
return Scope_Within_Or_Same (Etype (Context_Id), Ref_Id);
+
else
- pragma Assert
- (Is_Entry (Context_Id)
- or else
- Ekind_In (Context_Id, E_Function,
- E_Procedure,
- E_Task_Type));
+ pragma Assert (Ekind_In (Context_Id, E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Package,
+ E_Procedure,
+ E_Task_Type));
return Scope_Within_Or_Same (Context_Id, Ref_Id);
end if;
procedure Reset_Analyzed_Flags (N : Node_Id);
-- Reset the Analyzed flags in all nodes of the tree whose root is N
- procedure Restore_SPARK_Mode
- (Mode : SPARK_Mode_Type;
- Prag : Node_Id);
+ procedure Restore_SPARK_Mode (Mode : SPARK_Mode_Type; Prag : Node_Id);
-- Set the current SPARK_Mode to Mode and SPARK_Mode_Pragma to Prag. This
-- routine must be used in tandem with Set_SPARK_Mode.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
if Nkind (N) = N_Subprogram_Body then
Error_Msg_NE -- CODEFIX
("(style) missing OVERRIDING indicator in body of&", N, E);
+
+ elsif Nkind (N) = N_Abstract_Subprogram_Declaration then
+ Error_Msg_NE -- CODEFIX
+ ("(style) missing OVERRIDING indicator in deckaration of&",
+ Specification (N), E);
+
else
Error_Msg_NE -- CODEFIX
("(style) missing OVERRIDING indicator in declaration of&",
projects / gcc.git / commitdiff