From 3b2249aa1bb3f0240d45130a185c477c4530dc5a Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Thu, 27 Apr 2017 12:18:31 +0000 Subject: [PATCH] exp_ch9.adb (Expand_Entry_Barrier): Code cleanup. 2017-04-27 Hristian Kirtchev * exp_ch9.adb (Expand_Entry_Barrier): Code cleanup. Do not perform the optimization which removes the declarations of the discriminant and component renamings when validity checks on operands and attributes are in effect. 2017-04-27 Hristian Kirtchev * exp_spark.adb, exp_util.adb, sem_ch7.adb, g-dyntab.adb, g-dyntab.ads, freeze.adb, a-cfinve.ads, a-cofuma.adb, a-cofuma.ads, a-cfhama.adb, a-cfhama.ads, a-cofove.ads: Minor reformatting. 2017-04-27 Hristian Kirtchev * g-debpoo.adb (Dump_Gnatmem): Protect against a possible null pointer dereference. * g-spipat.adb (Dump): Code clean up. Protect against a possible null pointer dereference. From-SVN: r247326 --- gcc/ada/ChangeLog | 20 ++++ gcc/ada/a-cfhama.adb | 48 ++++---- gcc/ada/a-cfhama.ads | 48 ++++---- gcc/ada/a-cfinve.ads | 17 +-- gcc/ada/a-cofove.ads | 17 +-- gcc/ada/a-cofuma.adb | 8 +- gcc/ada/a-cofuma.ads | 10 +- gcc/ada/exp_ch9.adb | 63 +++++----- gcc/ada/exp_spark.adb | 4 +- gcc/ada/exp_util.adb | 11 +- gcc/ada/freeze.adb | 28 ++--- gcc/ada/g-debpoo.adb | 39 +++++-- gcc/ada/g-dyntab.adb | 21 +++- gcc/ada/g-dyntab.ads | 60 +++++----- gcc/ada/g-spipat.adb | 315 ++++++++++++++++++++++++++------------------------ gcc/ada/sem_ch7.adb | 6 +- 16 files changed, 391 insertions(+), 324 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ce6a02c..44c6ed5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2017-04-27 Hristian Kirtchev + + * exp_ch9.adb (Expand_Entry_Barrier): Code + cleanup. Do not perform the optimization which removes the + declarations of the discriminant and component renamings when + validity checks on operands and attributes are in effect. + +2017-04-27 Hristian Kirtchev + + * exp_spark.adb, exp_util.adb, sem_ch7.adb, g-dyntab.adb, g-dyntab.ads, + freeze.adb, a-cfinve.ads, a-cofuma.adb, a-cofuma.ads, a-cfhama.adb, + a-cfhama.ads, a-cofove.ads: Minor reformatting. + +2017-04-27 Hristian Kirtchev + + * g-debpoo.adb (Dump_Gnatmem): Protect against a possible null + pointer dereference. + * g-spipat.adb (Dump): Code clean up. Protect against a possible + null pointer dereference. + 2017-04-27 Bob Duff * g-dyntab.ads, g-dyntab.adb: Default for Table_Low_Bound. diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index c292701..526a556 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -38,7 +38,6 @@ with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Maps with SPARK_Mode => Off is - ----------------------- -- Local Subprograms -- ----------------------- @@ -112,8 +111,10 @@ is begin Node := Left.First.Node; while Node /= 0 loop - ENode := Find (Container => Right, - Key => Left.Nodes (Node).Key).Node; + ENode := + Find + (Container => Right, + Key => Left.Nodes (Node).Key).Node; if ENode = 0 or else Right.Nodes (ENode).Element /= Left.Nodes (Node).Element @@ -202,11 +203,11 @@ is Capacity : Count_Type := 0) return Map is C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); + Count_Type'Max (Capacity, Source.Capacity); + Cu : Cursor; H : Hash_Type; N : Count_Type; Target : Map (C, Source.Modulus); - Cu : Cursor; begin if 0 < Capacity and then Capacity < Source.Capacity then @@ -300,8 +301,8 @@ is raise Constraint_Error with "Position cursor equals No_Element"; end if; - pragma Assert (Vet (Container, Position), - "bad cursor in function Element"); + pragma Assert + (Vet (Container, Position), "bad cursor in function Element"); return Container.Nodes (Position.Node).Element; end Element; @@ -429,9 +430,12 @@ is -- for their postconditions. while Position /= 0 loop - R := M.Add (Container => R, - New_Key => Container.Nodes (Position).Key, - New_Item => Container.Nodes (Position).Element); + R := + M.Add + (Container => R, + New_Key => Container.Nodes (Position).Key, + New_Item => Container.Nodes (Position).Element); + Position := HT_Ops.Next (Container, Position); end loop; @@ -478,7 +482,6 @@ is ---------------------- procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is - procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); @@ -600,8 +603,7 @@ is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - raise Constraint_Error with - "attempt to insert key already in map"; + raise Constraint_Error with "attempt to insert key already in map"; end if; end Insert; @@ -647,8 +649,9 @@ is (Target : in out Map; Source : in out Map) is - NN : HT_Types.Nodes_Type renames Source.Nodes; - X, Y : Count_Type; + NN : HT_Types.Nodes_Type renames Source.Nodes; + X : Count_Type; + Y : Count_Type; begin if Target'Address = Source'Address then @@ -695,8 +698,7 @@ is end if; if not Has_Element (Container, Position) then - raise Constraint_Error - with "Position has no element"; + raise Constraint_Error with "Position has no element"; end if; pragma Assert (Vet (Container, Position), "bad cursor in function Next"); @@ -731,8 +733,7 @@ is begin if Node = 0 then - raise Constraint_Error with - "attempt to replace key not in map"; + raise Constraint_Error with "attempt to replace key not in map"; end if; declare @@ -758,8 +759,8 @@ is "Position cursor of Replace_Element has no element"; end if; - pragma Assert (Vet (Container, Position), - "bad cursor in Replace_Element"); + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; @@ -821,8 +822,9 @@ is return False; end if; - X := Container.Buckets - (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); + X := + Container.Buckets + (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); for J in 1 .. Container.Length loop if X = Position.Node then diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index 8f982fe..452e5ee 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -177,18 +177,16 @@ is -- It contains all the keys contained in Model - and - (for all Key of Model (Container) => - (for some L of Keys'Result => Equivalent_Keys (L, Key))) + and (for all Key of Model (Container) => + (for some L of Keys'Result => Equivalent_Keys (L, Key))) -- It has no duplicate - and - (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Keys - (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) - then I = J))); + and (for all I in 1 .. Length (Container) => + (for all J in 1 .. Length (Container) => + (if Equivalent_Keys + (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) + then I = J))); pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); function Positions (Container : Map) return P.Map with @@ -242,6 +240,7 @@ is K : Key_Type) return Element_Type renames M.Get; -- To improve readability of contracts, we rename the function used to -- access an element in the model to Element. + end Formal_Model; use Formal_Model; @@ -278,9 +277,8 @@ is -- Actual keys are preserved - and - (for all Key of Keys (Source) => - Formal_Hashed_Maps.Key (Target, Find (Target, Key)) = Key); + and (for all Key of Keys (Source) => + Formal_Hashed_Maps.Key (Target, Find (Target, Key)) = Key); function Copy (Source : Map; @@ -296,8 +294,8 @@ is Copy'Result.Capacity = Source.Capacity else Copy'Result.Capacity = Capacity); - -- Copy returns a container stricty equal to Source. It must have - -- the same cursors associated with each element. Therefore: + -- Copy returns a container stricty equal to Source. It must have the same + -- cursors associated with each element. Therefore: -- - capacity=0 means use Source.Capacity as capacity of target -- - the modulus cannot be changed. @@ -356,9 +354,8 @@ is -- Actual keys are preserved - and - (for all Key of Keys (Source)'Old => - Formal_Hashed_Maps.Key (Target, Find (Target, Key)) = Key); + and (for all Key of Keys (Source)'Old => + Formal_Hashed_Maps.Key (Target, Find (Target, Key)) = Key); procedure Insert (Container : in out Map; @@ -477,9 +474,9 @@ is -- The key equivalent to Key in Container is replaced by Key - and K.Get (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = - Key + and K.Get + (Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) = Key and K.Equal_Except (Keys (Container)'Old, Keys (Container), @@ -533,12 +530,13 @@ is -- The key equivalent to Key in Container is replaced by Key - and K.Get (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key + and K.Get + (Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) = Key and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) + (Keys (Container)'Old, + Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) -- New_Item is now associated with the Key in Container diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads index 9836c5f..98dcea1 100644 --- a/gcc/ada/a-cfinve.ads +++ b/gcc/ada/a-cfinve.ads @@ -58,19 +58,22 @@ is pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; No_Index : constant Extended_Index := Extended_Index'First; Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then 0 + (if Index_Type'Last < Index_Type'First then + 0 elsif Index_Type'Last < -1 or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else Count_Type'Last); + Index_Type'Pos (Index_Type'Last) - Count_Type'Last + then + Index_Type'Pos (Index_Type'Last) - + Index_Type'Pos (Index_Type'First) + 1 + else + Count_Type'Last); -- Maximal capacity of any vector. It is the minimum of the size of the -- index range and the last possible Count_Type. diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index efa5e9e..d9b68d0 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -52,19 +52,22 @@ is pragma Annotate (CodePeer, Skip_Analysis); subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; No_Index : constant Extended_Index := Extended_Index'First; Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then 0 + (if Index_Type'Last < Index_Type'First then + 0 elsif Index_Type'Last < -1 or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else Count_Type'Last); + Index_Type'Pos (Index_Type'Last) - Count_Type'Last + then + Index_Type'Pos (Index_Type'Last) - + Index_Type'Pos (Index_Type'First) + 1 + else + Count_Type'Last); -- Maximal capacity of any vector. It is the minimum of the size of the -- index range and the last possible Count_Type. diff --git a/gcc/ada/a-cofuma.adb b/gcc/ada/a-cofuma.adb index 38e481b..2e30089 100644 --- a/gcc/ada/a-cofuma.adb +++ b/gcc/ada/a-cofuma.adb @@ -95,8 +95,8 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is if not Equivalent_Keys (K, New_Key) and then (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, I)) + or else Get (Right.Elements, Find (Right.Keys, K)) /= + Get (Left.Elements, I)) then return False; end if; @@ -120,8 +120,8 @@ package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is and then not Equivalent_Keys (K, Y) and then (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, I)) + or else Get (Right.Elements, Find (Right.Keys, K)) /= + Get (Left.Elements, I)) then return False; end if; diff --git a/gcc/ada/a-cofuma.ads b/gcc/ada/a-cofuma.ads index 3f968dc..2d8a204 100644 --- a/gcc/ada/a-cofuma.ads +++ b/gcc/ada/a-cofuma.ads @@ -88,7 +88,7 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is Post => Has_Key (Container, Left) = Has_Key (Container, Right) and (if Has_Key (Container, Left) then - Get (Container, Left) = Get (Container, Right)); + Get (Container, Left) = Get (Container, Right)); ------------------------ -- Property Functions -- @@ -101,7 +101,7 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is Post => "<="'Result = (for all Key of Left => - Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); + Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); function "=" (Left : Map; Right : Map) return Boolean with -- Extensional equality over maps @@ -110,9 +110,9 @@ package Ada.Containers.Functional_Maps with SPARK_Mode is Post => "="'Result = ((for all Key of Left => - Has_Key (Right, Key) - and then Get (Right, Key) = Get (Left, Key)) - and (for all Key of Right => Has_Key (Left, Key))); + Has_Key (Right, Key) + and then Get (Right, Key) = Get (Left, Key)) + and (for all Key of Right => Has_Key (Left, Key))); pragma Warnings (Off, "unused variable ""Key"""); function Is_Empty (Container : Map) return Boolean with diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 81327c4..b79a41b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -63,6 +63,7 @@ with Stand; use Stand; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Validsw; use Validsw; package body Exp_Ch9 is @@ -5927,13 +5928,12 @@ package body Exp_Ch9 is -------------------------- procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is - Cond : constant Node_Id := - Condition (Entry_Body_Formal_Part (N)); + Cond : constant Node_Id := Condition (Entry_Body_Formal_Part (N)); Prot : constant Entity_Id := Scope (Ent); Spec_Decl : constant Node_Id := Parent (Prot); - Func : Entity_Id := Empty; - B_F : Node_Id; - Body_Decl : Node_Id; + + Func_Id : Entity_Id := Empty; + -- The entity of the barrier function function Is_Global_Entity (N : Node_Id) return Traverse_Result; -- Check whether entity in Barrier is external to protected type. @@ -5966,7 +5966,7 @@ package body Exp_Ch9 is -- during expansion, it is ok. If expansion is not performed, -- then Func is Empty so this test cannot succeed. - if Scope (E) = Func then + if Scope (E) = Func_Id then null; -- A protected call from a barrier to another object is ok @@ -6112,6 +6112,12 @@ package body Exp_Ch9 is function Check_Pure_Barriers is new Traverse_Func (Is_Pure_Barrier); + -- Local variables + + Cond_Id : Entity_Id; + Entry_Body : Node_Id; + Func_Body : Node_Id; + -- Start of processing for Expand_Entry_Barrier begin @@ -6130,20 +6136,20 @@ package body Exp_Ch9 is -- version of it because it is never called. if Expander_Active then - B_F := Build_Barrier_Function (N, Ent, Prot); - Func := Barrier_Function (Ent); - Set_Corresponding_Spec (B_F, Func); + Func_Body := Build_Barrier_Function (N, Ent, Prot); + Func_Id := Barrier_Function (Ent); + Set_Corresponding_Spec (Func_Body, Func_Id); - Body_Decl := Parent (Corresponding_Body (Spec_Decl)); + Entry_Body := Parent (Corresponding_Body (Spec_Decl)); - if Nkind (Parent (Body_Decl)) = N_Subunit then - Body_Decl := Corresponding_Stub (Parent (Body_Decl)); + if Nkind (Parent (Entry_Body)) = N_Subunit then + Entry_Body := Corresponding_Stub (Parent (Entry_Body)); end if; - Insert_Before_And_Analyze (Body_Decl, B_F); + Insert_Before_And_Analyze (Entry_Body, Func_Body); Set_Discriminals (Spec_Decl); - Set_Scope (Func, Scope (Prot)); + Set_Scope (Func_Id, Scope (Prot)); else Analyze_And_Resolve (Cond, Any_Boolean); @@ -6167,20 +6173,25 @@ package body Exp_Ch9 is -- scope. if Is_Entity_Name (Cond) then - - -- A small optimization of useless renamings. If the scope of the - -- entity of the condition is not the barrier function, then the - -- condition does not reference any of the generated renamings - -- within the function. - - if Expander_Active and then Scope (Entity (Cond)) /= Func then - Set_Declarations (B_F, Empty_List); + Cond_Id := Entity (Cond); + + -- Perform a small optimization of simple barrier functions. If the + -- scope of the condition's entity is not the barrier function, then + -- the condition does not depend on any of the generated renamings. + -- If this is the case, eliminate the renamings as they are useless. + -- This optimization is not performed when the condition was folded + -- and validity checks are in effect because the original condition + -- may have produced at least one check that depends on the generated + -- renamings. + + if Expander_Active + and then Scope (Cond_Id) /= Func_Id + and then not Validity_Check_Operands + then + Set_Declarations (Func_Body, Empty_List); end if; - if Entity (Cond) = Standard_False - or else - Entity (Cond) = Standard_True - then + if Cond_Id = Standard_False or else Cond_Id = Standard_True then return; elsif Is_Simple_Barrier_Name (Cond) then diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb index d7f1571..7062e13 100644 --- a/gcc/ada/exp_spark.adb +++ b/gcc/ada/exp_spark.adb @@ -251,9 +251,7 @@ package body Exp_SPARK is -- specialized to the descendant type, hence build a separate DIC -- procedure for it as done during regular expansion for compilation. - if Has_DIC (E) - and then Is_Tagged_Type (E) - then + if Has_DIC (E) and then Is_Tagged_Type (E) then Build_DIC_Procedure_Body (E, For_Freeze => True); end if; end Expand_SPARK_Freeze_Type; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4d923a0..2c23841 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1132,17 +1132,16 @@ package body Exp_Util is if not Is_Abstract_Subprogram (Subp) and then Is_Abstract_Subprogram (Entity (N)) then - Error_Msg_Sloc := Sloc (Current_Scope); - -- Error_Msg_Node_1 := Entity (N); + Error_Msg_Sloc := Sloc (Current_Scope); Error_Msg_Node_2 := Subp; if Comes_From_Source (Subp) then Error_Msg_NE - ("cannot call abstract subprogram& in inherited " - & "condition for&#", Subp, Entity (N)); + ("cannot call abstract subprogram & in inherited " + & "condition for&#", Subp, Entity (N)); else Error_Msg_NE - ("cannot call abstract subprogram& in inherited " - & "condition for inherited&#", Subp, Entity (N)); + ("cannot call abstract subprogram & in inherited " + & "condition for inherited&#", Subp, Entity (N)); end if; -- In SPARK mode, reject an inherited condition for an diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index b1fb3d3..d18d3d4 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1406,10 +1406,6 @@ package body Freeze is Par_Prim : Entity_Id; Prim : Entity_Id; - --------------------------------------- - -- Build_Inherited_Condition_Pragmas -- - --------------------------------------- - procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id); -- Build corresponding pragmas for an operation whose ancestor has -- class-wide pre/postconditions. If the operation is inherited, the @@ -1418,6 +1414,10 @@ package body Freeze is -- to verify their legality, in case they contain calls to other -- primitives that may haven been overridden. + --------------------------------------- + -- Build_Inherited_Condition_Pragmas -- + --------------------------------------- + procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is A_Post : Node_Id; A_Pre : Node_Id; @@ -1462,6 +1462,8 @@ package body Freeze is end if; end Build_Inherited_Condition_Pragmas; + -- Start of processing for Check_Inherited_Conditions + begin Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop @@ -1480,13 +1482,14 @@ package body Freeze is Next_Elmt (Op_Node); end loop; - -- Now perform validity checks on the inherited conditions of - -- overriding operations, for conformance with LSP, and apply - -- SPARK-specific restrictions on inherited conditions. + -- Perform validity checks on the inherited conditions of overriding + -- operations, for conformance with LSP, and apply SPARK-specific + -- restrictions on inherited conditions. Op_Node := First_Elmt (Prim_Ops); while Present (Op_Node) loop Prim := Node (Op_Node); + if Present (Overridden_Operation (Prim)) and then Comes_From_Source (Prim) then @@ -1505,11 +1508,10 @@ package body Freeze is if SPARK_Mode = On then Collect_Inherited_Class_Wide_Conditions (Prim); - else - - -- Build the corresponding pragmas to check for legality - -- of the inherited condition. + -- Otherwise build the corresponding pragmas to check for legality + -- of the inherited condition. + else Build_Inherited_Condition_Pragmas (Prim); end if; end if; @@ -1541,10 +1543,10 @@ package body Freeze is Build_Inherited_Condition_Pragmas (Prim); end if; - if Needs_Wrapper and then not Is_Abstract_Subprogram (Par_Prim) + if Needs_Wrapper + and then not Is_Abstract_Subprogram (Par_Prim) and then Expander_Active then - -- We need to build a new primitive that overrides the inherited -- one, and whose inherited expression has been updated above. -- These expressions are the arguments of pragmas that are part diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 9f8d57c..fe2debd 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.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- -- @@ -401,7 +401,7 @@ package body GNAT.Debug_Pools is --------------- function Header_Of (Address : System.Address) - return Allocation_Header_Access + return Allocation_Header_Access is function Convert is new Ada.Unchecked_Conversion (System.Address, Allocation_Header_Access); @@ -2293,8 +2293,12 @@ package body GNAT.Debug_Pools is begin File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); - fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, 1, - File); + + fwrite + (Ptr => Dummy_Time'Address, + Size => Duration'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); -- List of not deallocated blocks (see Print_Info) @@ -2303,9 +2307,9 @@ package body GNAT.Debug_Pools is Header := Header_Of (Current); Actual_Size := size_t (Header.Block_Size); - Tracebk := Header.Alloc_Traceback.Traceback; if Header.Alloc_Traceback /= null then + Tracebk := Header.Alloc_Traceback.Traceback; Num_Calls := Tracebk'Length; -- (Code taken from memtrack.adb in GNAT's sources) @@ -2316,12 +2320,24 @@ package body GNAT.Debug_Pools is fputc (Character'Pos ('A'), File); fwrite (Current'Address, Address_Size, 1, File); - fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, - 1, File); - fwrite (Dummy_Time'Address, Duration'Max_Size_In_Storage_Elements, - 1, File); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - File); + + fwrite + (Ptr => Actual_Size'Address, + Size => size_t'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); + + fwrite + (Ptr => Dummy_Time'Address, + Size => Duration'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); + + fwrite + (Ptr => Num_Calls'Address, + Size => Integer'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop declare @@ -2330,7 +2346,6 @@ package body GNAT.Debug_Pools is fwrite (Ptr'Address, Address_Size, 1, File); end; end loop; - end if; Current := Header.Next; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb index 1b53936..eff48cb 100644 --- a/gcc/ada/g-dyntab.adb +++ b/gcc/ada/g-dyntab.adb @@ -284,18 +284,24 @@ package body GNAT.Dynamic_Tables is -- Last, but if Release_Threshold /= 0, then we need to take that into -- account. + ------------------------ + -- New_Last_Allocated -- + ------------------------ + function New_Last_Allocated return Table_Last_Type is subtype Table_Length_Type is Table_Index_Type'Base range 0 .. Table_Index_Type'Base'Last; + Length : constant Table_Length_Type := T.P.Last - First + 1; + Comp_Size_In_Bytes : constant Table_Length_Type := Table_Type'Component_Size / System.Storage_Unit; + Length_Threshold : constant Table_Length_Type := Table_Length_Type (Release_Threshold) / Comp_Size_In_Bytes; + begin - if Release_Threshold = 0 - or else Length < Length_Threshold - then + if Release_Threshold = 0 or else Length < Length_Threshold then return T.P.Last; else declare @@ -306,6 +312,8 @@ package body GNAT.Dynamic_Tables is end if; end New_Last_Allocated; + -- Local variables + New_Last_Alloc : constant Table_Last_Type := New_Last_Allocated; -- Start of processing for Release @@ -324,15 +332,15 @@ package body GNAT.Dynamic_Tables is function To_Old_Alloc_Ptr is new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); - subtype Alloc_Type is - Table_Type (First .. New_Last_Alloc); + subtype Alloc_Type is Table_Type (First .. New_Last_Alloc); type Alloc_Ptr is access all Alloc_Type; function To_Table_Ptr is - new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); + new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); New_Table : constant Alloc_Ptr := new Alloc_Type; + begin New_Table (Alloc_Type'Range) := Old_Table (Alloc_Type'Range); T.P.Last_Allocated := New_Last_Alloc; @@ -353,6 +361,7 @@ package body GNAT.Dynamic_Tables is is pragma Assert (not T.Locked); Item_Copy : constant Table_Component_Type := Item; + begin -- If Set_Last is going to reallocate the table, we make a copy of Item, -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads index a983456..a1e9507 100644 --- a/gcc/ada/g-dyntab.ads +++ b/gcc/ada/g-dyntab.ads @@ -69,12 +69,12 @@ package GNAT.Dynamic_Tables is -- Table_Component_Type must not be a type with controlled parts. - -- The Table_Initial value controls the allocation of the table when - -- it is first allocated. + -- The Table_Initial value controls the allocation of the table when it is + -- first allocated. - -- The Table_Increment value controls the amount of increase, if the - -- table has to be increased in size. The value given is a percentage - -- value (e.g. 100 = increase table size by 100%, i.e. double it). + -- The Table_Increment value controls the amount of increase, if the table + -- has to be increased in size. The value given is a percentage value (e.g. + -- 100 = increase table size by 100%, i.e. double it). -- The Last and Set_Last subprograms provide control over the current -- logical allocation. They are quite efficient, so they can be used @@ -85,18 +85,18 @@ package GNAT.Dynamic_Tables is -- restrict the use of table for discriminated types. If it is necessary -- to take the access of a table element, use Unrestricted_Access. - -- WARNING: On HPPA, the virtual addressing approach used in this unit - -- is incompatible with the indexing instructions on the HPPA. So when - -- using this unit, compile your application with -mdisable-indexing. + -- WARNING: On HPPA, the virtual addressing approach used in this unit is + -- incompatible with the indexing instructions on the HPPA. So when using + -- this unit, compile your application with -mdisable-indexing. -- WARNING: If the table is reallocated, then the address of all its -- components will change. So do not capture the address of an element - -- and then use the address later after the table may be reallocated. - -- One tricky case of this is passing an element of the table to a - -- subprogram by reference where the table gets reallocated during - -- the execution of the subprogram. The best rule to follow is never - -- to pass a table element as a parameter except for the case of IN - -- mode parameters with scalar values. + -- and then use the address later after the table may be reallocated. One + -- tricky case of this is passing an element of the table to a subprogram + -- by reference where the table gets reallocated during the execution of + -- the subprogram. The best rule to follow is never to pass a table element + -- as a parameter except for the case of IN mode parameters with scalar + -- values. pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First); @@ -107,12 +107,12 @@ package GNAT.Dynamic_Tables is -- Table_Component_Type must not be a type with controlled parts. - -- The Table_Initial value controls the allocation of the table when - -- it is first allocated. + -- The Table_Initial value controls the allocation of the table when it is + -- first allocated. - -- The Table_Increment value controls the amount of increase, if the - -- table has to be increased in size. The value given is a percentage - -- value (e.g. 100 = increase table size by 100%, i.e. double it). + -- The Table_Increment value controls the amount of increase, if the table + -- has to be increased in size. The value given is a percentage value (e.g. + -- 100 = increase table size by 100%, i.e. double it). -- The Last and Set_Last subprograms provide control over the current -- logical allocation. They are quite efficient, so they can be used @@ -201,9 +201,9 @@ package GNAT.Dynamic_Tables is procedure Release (T : in out Instance); -- Storage is allocated in chunks according to the values given in the - -- Table_Initial and Table_Increment parameters. If Release_Threshold is 0 - -- or the length of the table does not exceed this threshold then a call to - -- Release releases all storage that is allocated, but is not logically + -- Table_Initial and Table_Increment parameters. If Release_Threshold is + -- 0 or the length of the table does not exceed this threshold then a call + -- to Release releases all storage that is allocated, but is not logically -- part of the current array value; otherwise the call to Release leaves -- the current array value plus 0.1% of the current table length free -- elements located at the end of the table. This parameter facilitates @@ -267,14 +267,14 @@ package GNAT.Dynamic_Tables is generic with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; procedure Sort_Table (Table : in out Instance); - -- This procedure sorts the components of the table into ascending - -- order making calls to Lt to do required comparisons, and using - -- assignments to move components around. The Lt function returns True - -- if Comp1 is less than Comp2 (in the sense of the desired sort), and - -- False if Comp1 is greater than Comp2. For equal objects it does not - -- matter if True or False is returned (it is slightly more efficient - -- to return False). The sort is not stable (the order of equal items - -- in the table is not preserved). + -- This procedure sorts the components of the table into ascending order + -- making calls to Lt to do required comparisons, and using assignments + -- to move components around. The Lt function returns True if Comp1 is + -- less than Comp2 (in the sense of the desired sort), and False if Comp1 + -- is greater than Comp2. For equal objects it does not matter if True or + -- False is returned (it is slightly more efficient to return False). The + -- sort is not stable (the order of equal items in the table is not + -- preserved). private diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb index 348c8e4..194a335 100644 --- a/gcc/ada/g-spipat.adb +++ b/gcc/ada/g-spipat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, AdaCore -- +-- Copyright (C) 1998-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- -- @@ -2086,28 +2086,15 @@ package body GNAT.Spitbol.Patterns is ---------- procedure Dump (P : Pattern) is - - subtype Count is Ada.Text_IO.Count; - Scol : Count; - -- Used to keep track of column in dump output - - Refs : Ref_Array (1 .. P.P.Index); - -- We build a reference array whose N'th element points to the - -- pattern element whose Index value is N. - - Cols : Natural := 2; - -- Number of columns used for pattern numbers, minimum is 2 - - E : PE_Ptr; - - procedure Write_Node_Id (E : PE_Ptr); - -- Writes out a string identifying the given pattern element + procedure Write_Node_Id (E : PE_Ptr; Cols : Natural); + -- Writes out a string identifying the given pattern element. Cols is + -- the column indentation level. ------------------- -- Write_Node_Id -- ------------------- - procedure Write_Node_Id (E : PE_Ptr) is + procedure Write_Node_Id (E : PE_Ptr; Cols : Natural) is begin if E = EOP then Put ("EOP"); @@ -2134,16 +2121,29 @@ package body GNAT.Spitbol.Patterns is end if; end Write_Node_Id; + -- Local variables + + Cols : Natural := 2; + -- Number of columns used for pattern numbers, minimum is 2 + + E : PE_Ptr; + + subtype Count is Ada.Text_IO.Count; + Scol : Count; + -- Used to keep track of column in dump output + -- Start of processing for Dump begin New_Line; - Put ("Pattern Dump Output (pattern at " & - Image (P'Address) & - ", S = " & Natural'Image (P.Stk) & ')'); + Put + ("Pattern Dump Output (pattern at " + & Image (P'Address) + & ", S = " + & Natural'Image (P.Stk) & ')'); + New_Line; Scol := Col; - New_Line; while Col < Scol loop Put ('-'); @@ -2165,144 +2165,151 @@ package body GNAT.Spitbol.Patterns is return; end if; - Build_Ref_Array (P.P, Refs); - - -- Set number of columns required for node numbers - - while 10 ** Cols - 1 < Integer (P.P.Index) loop - Cols := Cols + 1; - end loop; - - -- Now dump the nodes in reverse sequence. We output them in reverse - -- sequence since this corresponds to the natural order used to - -- construct the patterns. - - for J in reverse Refs'Range loop - E := Refs (J); - Write_Node_Id (E); - Set_Col (Count (Cols) + 4); - Put (Image (E)); - Put (" "); - Put (Pattern_Code'Image (E.Pcode)); - Put (" "); - Set_Col (21 + Count (Cols) + Address_Image_Length); - Write_Node_Id (E.Pthen); - Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); - - case E.Pcode is - when PC_Alt - | PC_Arb_X - | PC_Arbno_S - | PC_Arbno_X - => - Write_Node_Id (E.Alt); - - when PC_Rpat => - Put (Str_PP (E.PP)); - - when PC_Pred_Func => - Put (Str_BF (E.BF)); - - when PC_Assign_Imm - | PC_Assign_OnM - | PC_Any_VP - | PC_Break_VP - | PC_BreakX_VP - | PC_NotAny_VP - | PC_NSpan_VP - | PC_Span_VP - | PC_String_VP - => - Put (Str_VP (E.VP)); - - when PC_Write_Imm - | PC_Write_OnM - => - Put (Str_FP (E.FP)); - - when PC_String => - Put (Image (E.Str.all)); - - when PC_String_2 => - Put (Image (E.Str2)); - - when PC_String_3 => - Put (Image (E.Str3)); - - when PC_String_4 => - Put (Image (E.Str4)); - - when PC_String_5 => - Put (Image (E.Str5)); - - when PC_String_6 => - Put (Image (E.Str6)); + declare + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. - when PC_Setcur => - Put (Str_NP (E.Var)); - - when PC_Any_CH - | PC_Break_CH - | PC_BreakX_CH - | PC_Char - | PC_NotAny_CH - | PC_NSpan_CH - | PC_Span_CH - => - Put (''' & E.Char & '''); - - when PC_Any_CS - | PC_Break_CS - | PC_BreakX_CS - | PC_NotAny_CS - | PC_NSpan_CS - | PC_Span_CS - => - Put ('"' & To_Sequence (E.CS) & '"'); - - when PC_Arbno_Y - | PC_Len_Nat - | PC_Pos_Nat - | PC_RPos_Nat - | PC_RTab_Nat - | PC_Tab_Nat - => - Put (S (E.Nat)); + begin + Build_Ref_Array (P.P, Refs); - when PC_Pos_NF - | PC_Len_NF - | PC_RPos_NF - | PC_RTab_NF - | PC_Tab_NF - => - Put (Str_NF (E.NF)); + -- Set number of columns required for node numbers - when PC_Pos_NP - | PC_Len_NP - | PC_RPos_NP - | PC_RTab_NP - | PC_Tab_NP - => - Put (Str_NP (E.NP)); - - when PC_Any_VF - | PC_Break_VF - | PC_BreakX_VF - | PC_NotAny_VF - | PC_NSpan_VF - | PC_Span_VF - | PC_String_VF - => - Put (Str_VF (E.VF)); + while 10 ** Cols - 1 < Integer (P.P.Index) loop + Cols := Cols + 1; + end loop; - when others => - null; - end case; + -- Now dump the nodes in reverse sequence. We output them in reverse + -- sequence since this corresponds to the natural order used to + -- construct the patterns. + + for J in reverse Refs'Range loop + E := Refs (J); + Write_Node_Id (E, Cols); + Set_Col (Count (Cols) + 4); + Put (Image (E)); + Put (" "); + Put (Pattern_Code'Image (E.Pcode)); + Put (" "); + Set_Col (21 + Count (Cols) + Address_Image_Length); + Write_Node_Id (E.Pthen, Cols); + Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); + + case E.Pcode is + when PC_Alt + | PC_Arb_X + | PC_Arbno_S + | PC_Arbno_X + => + Write_Node_Id (E.Alt, Cols); + + when PC_Rpat => + Put (Str_PP (E.PP)); + + when PC_Pred_Func => + Put (Str_BF (E.BF)); + + when PC_Assign_Imm + | PC_Assign_OnM + | PC_Any_VP + | PC_Break_VP + | PC_BreakX_VP + | PC_NotAny_VP + | PC_NSpan_VP + | PC_Span_VP + | PC_String_VP + => + Put (Str_VP (E.VP)); + + when PC_Write_Imm + | PC_Write_OnM + => + Put (Str_FP (E.FP)); + + when PC_String => + Put (Image (E.Str.all)); + + when PC_String_2 => + Put (Image (E.Str2)); + + when PC_String_3 => + Put (Image (E.Str3)); + + when PC_String_4 => + Put (Image (E.Str4)); + + when PC_String_5 => + Put (Image (E.Str5)); + + when PC_String_6 => + Put (Image (E.Str6)); + + when PC_Setcur => + Put (Str_NP (E.Var)); + + when PC_Any_CH + | PC_Break_CH + | PC_BreakX_CH + | PC_Char + | PC_NotAny_CH + | PC_NSpan_CH + | PC_Span_CH + => + Put (''' & E.Char & '''); + + when PC_Any_CS + | PC_Break_CS + | PC_BreakX_CS + | PC_NotAny_CS + | PC_NSpan_CS + | PC_Span_CS + => + Put ('"' & To_Sequence (E.CS) & '"'); + + when PC_Arbno_Y + | PC_Len_Nat + | PC_Pos_Nat + | PC_RPos_Nat + | PC_RTab_Nat + | PC_Tab_Nat + => + Put (S (E.Nat)); + + when PC_Pos_NF + | PC_Len_NF + | PC_RPos_NF + | PC_RTab_NF + | PC_Tab_NF + => + Put (Str_NF (E.NF)); + + when PC_Pos_NP + | PC_Len_NP + | PC_RPos_NP + | PC_RTab_NP + | PC_Tab_NP + => + Put (Str_NP (E.NP)); + + when PC_Any_VF + | PC_Break_VF + | PC_BreakX_VF + | PC_NotAny_VF + | PC_NSpan_VF + | PC_Span_VF + | PC_String_VF + => + Put (Str_VF (E.VF)); + + when others => + null; + end case; + + New_Line; + end loop; New_Line; - end loop; - - New_Line; + end; end Dump; ---------- diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 6b2383a..266395a 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -983,9 +983,9 @@ package body Sem_Ch7 is Set_SPARK_Aux_Pragma_Inherited (Id); -- Save the state of flag Ignore_SPARK_Mode_Pragmas_In_Instance in case - -- the body of this package is instantiated or inlined later and out - -- of context. The body uses this attribute to restore the value of - -- the global flag. + -- the body of this package is instantiated or inlined later and out of + -- context. The body uses this attribute to restore the value of the + -- global flag. if Ignore_SPARK_Mode_Pragmas_In_Instance then Set_Ignore_SPARK_Mode_Pragmas (Id); -- 2.7.4