From 3815f967f9fa3655ee4e9cdc44d6292e09f411de Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:38:48 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Bob Duff * 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 * debug.adb: Minor reformatting. 2017-09-08 Bob Duff * 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 * s-hibaen.ads: Remove obsolete file. 2017-09-08 Arnaud Charlet * a-locale.ads: Add comment explaining the state of this package. 2017-09-08 Arnaud Charlet * 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 * checks.adb (Insert_Valid_Check): Copy the Do_Range_Check flag to the new Exp. From-SVN: r251875 --- gcc/ada/ChangeLog | 45 +++++++++++++ gcc/ada/a-cbdlli.adb | 17 +++-- gcc/ada/a-cohama.adb | 14 ++-- gcc/ada/a-cohase.adb | 14 ++-- gcc/ada/a-locale.ads | 6 +- gcc/ada/a-strfix.adb | 58 ++++++++++------- gcc/ada/a-strsea.ads | 10 +-- gcc/ada/a-stwise.ads | 10 +-- gcc/ada/a-stzsea.ads | 11 ++-- gcc/ada/binde.adb | 92 +++++++++++++++------------ gcc/ada/checks.adb | 8 ++- gcc/ada/debug.adb | 2 +- gcc/ada/g-except.ads | 8 +-- gcc/ada/lib-load.adb | 3 + gcc/ada/lib-xref-spark_specific.adb | 13 ++++ gcc/ada/repinfo.adb | 22 ++++++- gcc/ada/s-hibaen.ads | 99 ----------------------------- gcc/ada/s-purexc.ads | 8 +-- gcc/ada/s-trasym.adb | 25 ++++++-- gcc/ada/s-trasym.ads | 54 ++++++++-------- gcc/ada/sem_ch6.adb | 4 ++ gcc/ada/sem_prag.adb | 13 +++- gcc/ada/sem_prag.ads | 2 + gcc/ada/sem_res.adb | 4 +- gcc/ada/sem_util.adb | 13 ++-- gcc/ada/sem_util.ads | 4 +- gcc/ada/style.adb | 8 ++- 27 files changed, 313 insertions(+), 254 deletions(-) delete mode 100644 gcc/ada/s-hibaen.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 53f380a2945..5a87f681dc9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,48 @@ +2017-09-08 Bob Duff + +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 + + * 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 + + * debug.adb: Minor reformatting. + +2017-09-08 Bob Duff + + * 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 + + * s-hibaen.ads: Remove obsolete file. + +2017-09-08 Arnaud Charlet + + * a-locale.ads: Add comment explaining the state of this package. + +2017-09-08 Arnaud Charlet + + * 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 + + * checks.adb (Insert_Valid_Check): Copy the Do_Range_Check flag to the + new Exp. + 2017-09-08 Eric Botcazou * debug.adb (dA): Adjust comment. diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb index c2799436053..b19fc3c293e 100644 --- a/gcc/ada/a-cbdlli.adb +++ b/gcc/ada/a-cbdlli.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -329,12 +329,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is 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 @@ -1014,7 +1017,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is 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 @@ -1023,7 +1026,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is -- 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; --------------------- diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index c71576c1f84..4ead9255307 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -263,15 +263,15 @@ package body Ada.Containers.Hashed_Maps is 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 diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index bde87049485..3056f547ee6 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -248,15 +248,15 @@ package body Ada.Containers.Hashed_Sets is 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 diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads index 132c8832b7b..605ce20c013 100644 --- a/gcc/ada/a-locale.ads +++ b/gcc/ada/a-locale.ads @@ -6,7 +6,7 @@ -- -- -- 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 -- @@ -15,6 +15,10 @@ -- -- ------------------------------------------------------------------------------ +-- 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); diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb index 2f140d8aa4a..0f24f5a5fc7 100644 --- a/gcc/ada/a-strfix.adb +++ b/gcc/ada/a-strfix.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -627,47 +627,61 @@ package body Ada.Strings.Fixed is (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 diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads index bf8686815c0..380444aff3a 100644 --- a/gcc/ada/a-strsea.ads +++ b/gcc/ada/a-strsea.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,10 +31,10 @@ -- 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; diff --git a/gcc/ada/a-stwise.ads b/gcc/ada/a-stwise.ads index fa06c5b1502..66d9cb2be38 100644 --- a/gcc/ada/a-stwise.ads +++ b/gcc/ada/a-stwise.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,10 +31,10 @@ -- 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; diff --git a/gcc/ada/a-stzsea.ads b/gcc/ada/a-stzsea.ads index b8e39d25a4e..1875af78af3 100644 --- a/gcc/ada/a-stzsea.ads +++ b/gcc/ada/a-stzsea.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -31,11 +31,10 @@ -- 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; diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 9318fd76fa7..dd076be3acf 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -282,6 +282,9 @@ package body Binde is 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 -- ----------------------- @@ -429,9 +432,9 @@ package body Binde is 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 @@ -1027,22 +1030,23 @@ package body Binde is 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); + <> null; end if; -- For all successors, decrement the number of predecessors, and if it @@ -1268,6 +1272,7 @@ package body Binde is -- 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 @@ -1279,10 +1284,8 @@ package body Binde is 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 @@ -1294,17 +1297,14 @@ package body Binde is 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; @@ -1329,8 +1329,7 @@ package body Binde is 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; @@ -1635,7 +1634,7 @@ package body Binde is 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..."); @@ -1646,6 +1645,9 @@ package body Binde is 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)); @@ -2386,8 +2388,7 @@ package body Binde is 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 @@ -2406,8 +2407,7 @@ package body Binde is Write_Str (" "); end if; - Write_Str (Get_Name_String (Source)); - Write_Eol; + Write_Line (Get_Name_String (Source)); end if; end loop; @@ -2430,8 +2430,7 @@ package body Binde is Write_Str (" "); end if; - Write_Str (Get_Name_String (Source)); - Write_Eol; + Write_Line (Get_Name_String (Source)); end if; end loop; @@ -2448,8 +2447,7 @@ package body Binde is begin if not Zero_Formatting then Write_Eol; - Write_Str (" ELABORATION ORDER DEPENDENCIES"); - Write_Eol; + Write_Line (" ELABORATION ORDER DEPENDENCIES"); Write_Eol; end if; @@ -2535,8 +2533,7 @@ package body Binde is begin if Title /= "" then Write_Eol; - Write_Str (Title); - Write_Eol; + Write_Line (Title); end if; for J in Order'Range loop @@ -2751,8 +2748,7 @@ package body Binde is 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 (" "); @@ -2901,12 +2897,12 @@ package body Binde is 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 @@ -2958,6 +2954,9 @@ package body Binde is -- 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 @@ -3003,17 +3002,29 @@ package body Binde is 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]"); @@ -3200,8 +3211,7 @@ package body Binde is 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; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 7962b7b47df..8dd7a3907c6 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -7401,10 +7401,16 @@ package body Checks is 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: diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 3dbe1f9ae87..6b740ff5cef 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -608,7 +608,7 @@ package body Debug is -- 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 diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads index 3e8c2d1b052..69ae9285e37 100644 --- a/gcc/ada/g-except.ads +++ b/gcc/ada/g-except.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -57,9 +57,9 @@ package GNAT.Exceptions is -- 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 diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index e05bde164b3..e18fa246f88 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -328,6 +328,9 @@ package body Lib.Load is 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) := diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb index b627a8e59ee..f210112deb3 100644 --- a/gcc/ada/lib-xref-spark_specific.adb +++ b/gcc/ada/lib-xref-spark_specific.adb @@ -738,6 +738,19 @@ package body SPARK_Specific is 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; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a6d60cbf1d3..e5ea7b02843 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -854,7 +854,6 @@ package body Repinfo is ---------------------- procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is - procedure Compute_Max_Length (Ent : Entity_Id; Starting_Position : Uint := Uint_0; @@ -882,7 +881,7 @@ package body Repinfo is Starting_First_Bit : Uint := Uint_0; Prefix_Length : Natural := 0) is - Comp : Entity_Id; + Comp : Entity_Id; begin Comp := First_Component_Or_Discriminant (Ent); @@ -905,7 +904,9 @@ package body Repinfo is Fbit : Uint; Spos : Uint; Sbit : Uint; + Name_Length : Natural; + begin Get_Decoded_Name_String (Chars (Comp)); Name_Length := Prefix_Length + Name_Len; @@ -936,6 +937,7 @@ package body Repinfo is Spos := Starting_Position + Npos; Sbit := Starting_First_Bit + Fbit; + if Sbit >= SSU then Spos := Spos + 1; Sbit := Sbit - SSU; @@ -974,7 +976,7 @@ package body Repinfo is Starting_First_Bit : Uint := Uint_0; Prefix : String := "") is - Comp : Entity_Id; + Comp : Entity_Id; begin Comp := First_Component_Or_Discriminant (Ent); @@ -1014,12 +1016,15 @@ package body Repinfo is 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; @@ -1036,9 +1041,11 @@ package body Repinfo is 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)); @@ -1048,6 +1055,7 @@ package body Repinfo is then Spaces (Max_Spos_Length - 2); Write_Str ("bit offset"); + if Starting_Position /= Uint_0 or else Starting_First_Bit /= Uint_0 then @@ -1055,21 +1063,25 @@ package body Repinfo is 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 @@ -1089,9 +1101,11 @@ package body Repinfo is Write_Str (" range "); Sbit := Starting_First_Bit + Fbit; + if Sbit >= SSU then Sbit := Sbit - SSU; end if; + UI_Write (Sbit); Write_Str (" .. "); @@ -1158,6 +1172,8 @@ package body Repinfo is end loop; end List_Record_Layout; + -- Start of processing for List_Record_Info + begin Blank_Line; List_Type_Info (Ent); diff --git a/gcc/ada/s-hibaen.ads b/gcc/ada/s-hibaen.ads deleted file mode 100644 index fb8c2c8aaad..00000000000 --- a/gcc/ada/s-hibaen.ads +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- . -- --- -- --- 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; diff --git a/gcc/ada/s-purexc.ads b/gcc/ada/s-purexc.ads index ab05e2ae0ee..946d21d6f71 100644 --- a/gcc/ada/s-purexc.ads +++ b/gcc/ada/s-purexc.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -52,9 +52,9 @@ package System.Pure_Exceptions is -- 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 diff --git a/gcc/ada/s-trasym.adb b/gcc/ada/s-trasym.adb index e1f72dba521..070f9a95e3b 100644 --- a/gcc/ada/s-trasym.adb +++ b/gcc/ada/s-trasym.adb @@ -42,6 +42,8 @@ with System.Address_Image; package body System.Traceback.Symbolic is + -- Note that Suppress_Hex is ignored in this version of this package. + ------------------------ -- Symbolic_Traceback -- ------------------------ @@ -63,11 +65,11 @@ package body System.Traceback.Symbolic is 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; @@ -76,6 +78,15 @@ package body System.Traceback.Symbolic is 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 @@ -83,6 +94,12 @@ package body System.Traceback.Symbolic 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 -- ------------------ diff --git a/gcc/ada/s-trasym.ads b/gcc/ada/s-trasym.ads index 4d3c9221fbd..ba9c89ea6c6 100644 --- a/gcc/ada/s-trasym.ads +++ b/gcc/ada/s-trasym.ads @@ -31,26 +31,26 @@ -- 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 *) 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 *) 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 @@ -58,10 +58,6 @@ -- 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. @@ -73,22 +69,30 @@ package System.Traceback.Symbolic is 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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c5b2aa75275..dc98ad55d7d 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3060,8 +3060,12 @@ package body Sem_Ch6 is -- 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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7bfb53e79c4..674c944d860 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -28793,7 +28793,8 @@ package body Sem_Prag is 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 @@ -28892,6 +28893,11 @@ package body Sem_Prag is 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 @@ -28902,6 +28908,11 @@ package body Sem_Prag is 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. diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 4c387121aeb..ff4a1cba043 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -375,6 +375,7 @@ package Sem_Prag is -- Depends -- Extensions_Visible -- Global + -- Initializes -- Max_Queue_Length -- Post -- Post_Class @@ -385,6 +386,7 @@ package Sem_Prag is -- Refined_Depends -- Refined_Global -- Refined_Post + -- Refined_State -- Test_Case -- Volatile_Function -- as well as attributes 'Old and 'Result. Find the declaration of the diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fc997539925..d8f907658e4 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8009,8 +8009,8 @@ package body Sem_Res is 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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 465d1412e3f..b03926b37ec 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12395,13 +12395,14 @@ package body Sem_Util is 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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a17179f382a..2d6de5cad41 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2329,9 +2329,7 @@ package Sem_Util is 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. diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index e58d5052d70..e475b82a360 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -288,6 +288,12 @@ package body Style is 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&", -- 2.30.2