+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * 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 <kirtchev@adacore.com>
+
+ * 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 <duff@adacore.com>
* g-dyntab.ads, g-dyntab.adb: Default for Table_Low_Bound.
package body Ada.Containers.Formal_Hashed_Maps with
SPARK_Mode => Off
is
-
-----------------------
-- Local Subprograms --
-----------------------
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
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
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;
-- 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;
----------------------
procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
-
procedure Allocate is
new HT_Ops.Generic_Allocate (Set_Element);
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;
(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
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");
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
"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;
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
-- 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
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;
-- 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;
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.
-- 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;
-- 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),
-- 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
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.
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.
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;
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;
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 --
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
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
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Validsw; use Validsw;
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.
-- 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
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
-- 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);
-- 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
-- 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;
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
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
-- 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;
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
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
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;
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
-- --
-- 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- --
---------------
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);
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)
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)
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
fwrite (Ptr'Address, Address_Size, 1, File);
end;
end loop;
-
end if;
Current := Header.Next;
-- 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
end if;
end New_Last_Allocated;
+ -- Local variables
+
New_Last_Alloc : constant Table_Last_Type := New_Last_Allocated;
-- Start of processing for Release
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;
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
-- 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
-- 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);
-- 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
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
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
-- --
-- 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- --
----------
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");
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 ('-');
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;
----------
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);
projects / gcc.git / commitdiff