Skip to content

R
riscv-gcc-1
Commit 5ffe0bab by Arnaud Charlet
Options

[multiple changes] 

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* scos.adb, get_scos.adb, put_scos.adb
	New code letter for decisions: G (entry guard)
	* par_sco.adb
	(Traverse_Subprogram_Body): Rename to...
	(Traverse_Subprogram_Or_Task_Body): New subrpogram.
	(Traverse_Protected_Body): New subprogram
	(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
	protected bodies and entry bodies.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
	entities with get/set subprograms, which is set on procedure entities
	generated by the compiler for a postcondition.
	* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
	* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
	entity for a declaration
	(Get_Unique_Entity_For_Decl): new function returning an entity which
	represents a declaration, so that matching spec and body have the same
	entity.

2011-08-03  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
	a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting

2011-08-03  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
	library-level because retriction No_Implicit_Dynamic_Code in the
	front-end prevents its definition as a local subprogram
	(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
	for reuse in other contexts
	(Traverse_Declarations_Or_Statements,
	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
	Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
	procedures take a callback parameter to be called on all declarations
	* lib-xref.ads
	(Traverse_All_Compilation_Units): new generic function to traverse a
	compilation unit and call a callback parameter on all declarations

From-SVN: r177284
parent f9ad6b62
Showing with 481 additions and 379 deletions
gcc/ada/ChangeLog
2011-08-03 Thomas Quinot <quinot@adacore.com>
* scos.adb, get_scos.adb, put_scos.adb
New code letter for decisions: G (entry guard)
* par_sco.adb
(Traverse_Subprogram_Body): Rename to...
(Traverse_Subprogram_Or_Task_Body): New subrpogram.
(Traverse_Protected_Body): New subprogram
(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
protected bodies and entry bodies.
2011-08-03 Yannick Moy <moy@adacore.com>
* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
entities with get/set subprograms, which is set on procedure entities
generated by the compiler for a postcondition.
* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
entity for a declaration
(Get_Unique_Entity_For_Decl): new function returning an entity which
represents a declaration, so that matching spec and body have the same
entity.
2011-08-03 Robert Dewar <dewar@adacore.com>
* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting
2011-08-03 Yannick Moy <moy@adacore.com>
* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
library-level because retriction No_Implicit_Dynamic_Code in the
front-end prevents its definition as a local subprogram
(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
for reuse in other contexts
(Traverse_Declarations_Or_Statements,
Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
procedures take a callback parameter to be called on all declarations
* lib-xref.ads
(Traverse_All_Compilation_Units): new generic function to traverse a
compilation unit and call a callback parameter on all declarations
2011-08-03 Javier Miranda <miranda@adacore.com>
* sem_prag.adb (Process_Interface_Name): Allow duplicated export names
......
gcc/ada/a-cfhama.adb
......@@ -41,6 +41,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Local Subprograms --
-----------------------
-- All local subprograms require comments ???
function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean;
......@@ -93,7 +95,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
function "=" (Left, Right : Map) return Boolean is
begin
if Length (Left) /= Length (Right) then
return False;
end if;
......@@ -103,13 +104,15 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
declare
Node : Count_Type := Left.First.Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
Node := Left.First.Node;
while Node /= 0 loop
ENode := Find (Container => Right,
Key => Left.Nodes (Node).Key).Node;
if ENode = 0 or else
Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
then
......@@ -120,9 +123,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
end loop;
return True;
end;
end "=";
------------
......@@ -149,7 +150,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -159,7 +159,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Source length exceeds Target capacity";
end if;
Clear (Target); -- checks busy bits
-- Check busy bits
Clear (Target);
Insert_Elements (Source);
end Assign;
......@@ -201,27 +203,33 @@ package body Ada.Containers.Formal_Hashed_Maps is
is
C : constant Count_Type :=
Count_Type'Max (Capacity, Source.Capacity);
H : Hash_Type := 1;
N : Count_Type := 1;
H : Hash_Type;
N : Count_Type;
Target : Map (C, Source.Modulus);
Cu : Cursor;
begin
begin
Target.Length := Source.Length;
Target.Free := Source.Free;
H := 1;
while H <= Source.Modulus loop
Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
Free (Target, Cu.Node);
N := N + 1;
end loop;
return Target;
end Copy;
......@@ -242,7 +250,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
X : Count_Type;
begin
Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
......@@ -254,7 +261,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
......@@ -306,14 +312,18 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean is
Node : Node_Type) return Boolean
is
begin
return Equivalent_Keys (Key, Node.Key);
end Equivalent_Keys;
function Equivalent_Keys (Left : Map; CLeft : Cursor;
Right : Map; CRight : Cursor)
return Boolean is
function Equivalent_Keys
(Left : Map;
CLeft : Cursor;
Right : Map;
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
......@@ -331,10 +341,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Right cursor of Equivalent_Keys is bad");
declare
LN : Node_Type renames Left.Nodes (CLeft.Node);
RN : Node_Type renames Right.Nodes (CRight.Node);
begin
return Equivalent_Keys (LN.Key, RN.Key);
end;
......@@ -343,7 +351,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Left : Map;
CLeft : Cursor;
Right : Key_Type) return Boolean is
Right : Key_Type) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
......@@ -355,7 +364,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
declare
LN : Node_Type renames Left.Nodes (CLeft.Node);
begin
return Equivalent_Keys (LN.Key, Right);
end;
......@@ -364,7 +372,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Equivalent_Keys
(Left : Key_Type;
Right : Map;
CRight : Cursor) return Boolean is
CRight : Cursor) return Boolean
is
begin
if Has_Element (Right, CRight) then
raise Constraint_Error with
......@@ -422,17 +431,13 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
return (Node => Node);
end First;
----------
-- Free --
----------
procedure Free
(HT : in out Map;
X : Count_Type)
is
procedure Free (HT : in out Map; X : Count_Type) is
begin
HT.Nodes (X).Has_Element := False;
HT_Ops.Free (HT, X);
......@@ -442,10 +447,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Generic_Allocate --
----------------------
procedure Generic_Allocate
(HT : in out Map;
Node : out Count_Type)
is
procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
procedure Allocate is
new HT_Ops.Generic_Allocate (Set_Element);
......@@ -465,6 +467,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
not Container.Nodes (Position.Node).Has_Element then
return False;
end if;
return True;
end Has_Element;
......@@ -472,8 +475,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Hash_Node --
---------------
function Hash_Node
(Node : Node_Type) return Hash_Type is
function Hash_Node (Node : Node_Type) return Hash_Type is
begin
return Hash (Node.Key);
end Hash_Node;
......@@ -537,6 +539,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Assign_Key (Node : in out Node_Type) is
begin
Node.Key := Key;
-- What is following commented out line doing here ???
-- Node.Element := New_Item;
end Assign_Key;
......@@ -601,7 +605,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Start of processing for Insert
begin
Local_Insert (Container, Key, Position.Node, Inserted);
end Insert;
......@@ -639,8 +642,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor))
Process : not null
access procedure (Container : Map; Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
......@@ -695,14 +698,18 @@ package body Ada.Containers.Formal_Hashed_Maps is
----------
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor := Position;
Curs : Cursor;
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
Curs := Position;
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
......@@ -712,6 +719,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
......@@ -736,7 +744,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
X, Y : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -816,6 +823,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Overlap (Left, Right : Map) return Boolean is
Left_Node : Count_Type;
Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
......@@ -826,12 +834,10 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
Left_Node := First (Left).Node;
while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Key_Type renames N.Key;
begin
if Find (Right, E).Node /= 0 then
return True;
......@@ -855,7 +861,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure (Key : Key_Type; Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
......@@ -865,7 +870,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......@@ -876,7 +880,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
declare
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
......@@ -909,8 +912,8 @@ package body Ada.Containers.Formal_Hashed_Maps is
-- Read_Node --
---------------
function Read_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type
function Read_Node
(Stream : not null access Root_Stream_Type'Class) return Count_Type
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
......@@ -933,6 +936,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
end Read_Node;
-- Start of processing for Read
begin
Read_Nodes (Stream, Container);
end Read;
......@@ -957,7 +961,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
if Node = 0 then
raise Constraint_Error with
"attempt to replace key not in map";
......@@ -986,7 +989,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
......@@ -1012,7 +1014,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Capacity : Count_Type)
is
begin
if Capacity > Container.Capacity then
raise Capacity_Error with "requested capacity is too large";
end if;
......@@ -1027,11 +1028,13 @@ package body Ada.Containers.Formal_Hashed_Maps is
C : Map (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
......@@ -1041,6 +1044,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
......@@ -1060,6 +1064,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
function Strict_Equal (Left, Right : Map) return Boolean is
CuL : Cursor := First (Left);
CuR : Cursor := First (Right);
begin
if Length (Left) /= Length (Right) then
return False;
......@@ -1073,6 +1078,7 @@ package body Ada.Containers.Formal_Hashed_Maps is
Right.Nodes (CuR.Node).Key) then
return False;
end if;
CuL := Next (Left, CuL);
CuR := Next (Right, CuR);
end loop;
......@@ -1173,7 +1179,9 @@ package body Ada.Containers.Formal_Hashed_Maps is
end if;
if X = Container.Nodes (X).Next then
-- to prevent unnecessary looping
-- Prevent unnecessary looping
return False;
end if;
......
gcc/ada/a-cfhase.adb
......@@ -41,6 +41,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Local Subprograms --
-----------------------
-- All need comments ???
procedure Difference
(Left, Right : Set;
Target : in out Set);
......@@ -117,7 +119,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
function "=" (Left, Right : Set) return Boolean is
begin
if Length (Left) /= Length (Right) then
return False;
end if;
......@@ -127,10 +128,11 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
declare
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
Node := First (Left).Node;
while Node /= 0 loop
ENode := Find (Container => Right,
Item => Left.Nodes (Node).Element).Node;
......@@ -176,7 +178,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -204,7 +205,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Clear (Container : in out Set) is
begin
HT_Ops.Clear (Container);
end Clear;
......@@ -227,27 +227,33 @@ package body Ada.Containers.Formal_Hashed_Sets is
is
C : constant Count_Type :=
Count_Type'Max (Capacity, Source.Capacity);
H : Hash_Type := 1;
N : Count_Type := 1;
H : Hash_Type;
N : Count_Type;
Target : Set (C, Source.Modulus);
Cu : Cursor;
begin
begin
Target.Length := Source.Length;
Target.Free := Source.Free;
H := 1;
while H <= Source.Modulus loop
Target.Buckets (H) := Source.Buckets (H);
H := H + 1;
end loop;
N := 1;
while N <= Source.Capacity loop
Target.Nodes (N) := Source.Nodes (N);
N := N + 1;
end loop;
while N <= C loop
Cu := (Node => N);
Free (Target, Cu.Node);
N := N + 1;
end loop;
return Target;
end Copy;
......@@ -271,12 +277,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
X : Count_Type;
begin
Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
Free (Container, X);
end Delete;
......@@ -285,7 +291,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
Position : in out Cursor)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
......@@ -317,7 +322,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
SN : Nodes_Type renames Source.Nodes;
begin
if Target'Address = Source'Address then
Clear (Target);
return;
......@@ -337,8 +341,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
if Src_Length >= Target.Length then
Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
if Element_Keys.Find (Source,
TN (Tgt_Node).Element) /= 0 then
if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
declare
X : constant Count_Type := Tgt_Node;
begin
......@@ -346,10 +349,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
HT_Ops.Delete_Node_Sans_Free (Target, X);
Free (Target, X);
end;
else
Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
end if;
end loop;
return;
else
Src_Node := HT_Ops.First (Source);
......@@ -357,8 +362,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
while Src_Node /= Src_Last loop
Tgt_Node := Element_Keys.Find
(Target, SN (Src_Node).Element);
Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
if Tgt_Node /= 0 then
HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
......@@ -386,7 +390,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
E : Element_Type renames Left.Nodes (L_Node).Element;
X : Count_Type;
B : Boolean;
begin
if Find (Right, E).Node = 0 then
Insert (Target, E, X, B);
......@@ -403,6 +406,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Difference (Left, Right : Set) return Set is
C : Count_Type;
H : Hash_Type;
begin
if Left'Address = Right'Address then
return Empty_Set;
......@@ -418,6 +422,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Length (Left);
H := Default_Modulus (C);
return S : Set (C, H) do
Difference (Left, Right, Target => S);
end return;
......@@ -429,7 +434,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Element
(Container : Set;
Position : Cursor) return Element_Type is
Position : Cursor) return Element_Type
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor equals No_Element";
......@@ -465,9 +471,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
is
R_Index : constant Hash_Type :=
Element_Keys.Index (R_HT, L_Node.Element);
R_Node : Count_Type := R_HT.Buckets (R_Index);
RN : Nodes_Type renames R_HT.Nodes;
begin
......@@ -495,9 +499,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Equivalent_Elements --
-------------------------
function Equivalent_Elements (Left : Set; CLeft : Cursor;
Right : Set; CRight : Cursor)
return Boolean is
function Equivalent_Elements
(Left : Set;
CLeft : Cursor;
Right : Set;
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
......@@ -525,7 +532,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Equivalent_Elements
(Left : Set;
CLeft : Cursor;
Right : Element_Type) return Boolean is
Right : Element_Type) return Boolean
is
begin
if not Has_Element (Left, CLeft) then
raise Constraint_Error with
......@@ -545,7 +553,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Equivalent_Elements
(Left : Element_Type;
Right : Set;
CRight : Cursor) return Boolean is
CRight : Cursor) return Boolean
is
begin
if not Has_Element (Right, CRight) then
raise Constraint_Error with
......@@ -563,14 +572,17 @@ package body Ada.Containers.Formal_Hashed_Sets is
end;
end Equivalent_Elements;
-- What does the following comment signify???
-- NOT MODIFIED
---------------------
-- Equivalent_Keys --
---------------------
function Equivalent_Keys (Key : Element_Type; Node : Node_Type)
return Boolean is
function Equivalent_Keys
(Key : Element_Type;
Node : Node_Type) return Boolean
is
begin
return Equivalent_Elements (Key, Node.Element);
end Equivalent_Keys;
......@@ -597,15 +609,14 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : Set;
Item : Element_Type) return Cursor
is
Node : constant Count_Type :=
Element_Keys.Find (Container, Item);
Node : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (Node => Node);
end Find;
-----------
......@@ -614,13 +625,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
function First (Container : Set) return Cursor is
Node : constant Count_Type := HT_Ops.First (Container);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
end First;
----------
......@@ -644,10 +655,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
(HT : in out Set;
Node : out Count_Type)
is
procedure Allocate is
new HT_Ops.Generic_Allocate (Set_Element);
procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
begin
Allocate (HT, Node);
HT.Nodes (Node).Has_Element := True;
......@@ -659,10 +667,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Has_Element (Container : Set; Position : Cursor) return Boolean is
begin
if Position.Node = 0 or else
not Container.Nodes (Position.Node).Has_Element then
if Position.Node = 0
or else not Container.Nodes (Position.Node).Has_Element
then
return False;
end if;
return True;
end Has_Element;
......@@ -770,9 +780,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Start of processing for Insert
begin
Local_Insert (Container, New_Item, Node, Inserted);
end Insert;
------------------
......@@ -787,7 +795,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
TN : Nodes_Type renames Target.Nodes;
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -862,6 +869,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Count_Type'Min (Length (Left), Length (Right)); -- ???
H := Default_Modulus (C);
return S : Set (C, H) do
if Length (Left) /= 0 and Length (Right) /= 0 then
Intersection (Left, Right, Target => S);
......@@ -882,8 +890,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Is_In --
-----------
function Is_In (HT : Set;
Key : Node_Type) return Boolean is
function Is_In (HT : Set; Key : Node_Type) return Boolean is
begin
return Element_Keys.Find (HT, Key.Element) /= 0;
end Is_In;
......@@ -895,6 +902,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
Subset_Node : Count_Type;
Subset_Nodes : Nodes_Type renames Subset.Nodes;
begin
if Subset'Address = Of_Set'Address then
return True;
......@@ -905,7 +913,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
Subset_Node := First (Subset).Node;
while Subset_Node /= 0 loop
declare
N : Node_Type renames Subset_Nodes (Subset_Node);
......@@ -974,10 +981,12 @@ package body Ada.Containers.Formal_Hashed_Sets is
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
......@@ -987,6 +996,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
......@@ -1003,12 +1013,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Move --
----------
-- Comments???
procedure Move (Target : in out Set; Source : in out Set) is
NN : HT_Types.Nodes_Type renames Source.Nodes;
X, Y : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -1079,6 +1090,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Overlap (Left, Right : Set) return Boolean is
Left_Node : Count_Type;
Left_Nodes : Nodes_Type renames Left.Nodes;
begin
if Length (Right) = 0 or Length (Left) = 0 then
return False;
......@@ -1089,12 +1101,10 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
Left_Node := First (Left).Node;
while Left_Node /= 0 loop
declare
N : Node_Type renames Left_Nodes (Left_Node);
E : Element_Type renames N.Element;
begin
if Find (Right, E).Node /= 0 then
return True;
......@@ -1125,7 +1135,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......@@ -1171,8 +1180,11 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is
new Generic_Allocate (Read_Element);
procedure Allocate is new Generic_Allocate (Read_Element);
------------------
-- Read_Element --
------------------
procedure Read_Element (Node : in out Node_Type) is
begin
......@@ -1189,8 +1201,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
end Read_Node;
-- Start of processing for Read
begin
begin
Read_Nodes (Stream, Container);
end Read;
......@@ -1210,11 +1222,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : in out Set;
New_Item : Element_Type)
is
Node : constant Count_Type :=
Element_Keys.Find (Container, New_Item);
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
if Node = 0 then
raise Constraint_Error with
"attempt to replace element not in set";
......@@ -1238,7 +1248,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor equals No_Element";
......@@ -1273,11 +1282,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
C : Set (Container.Capacity, Container.Modulus) :=
Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
......@@ -1287,6 +1298,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
......@@ -1315,17 +1327,20 @@ package body Ada.Containers.Formal_Hashed_Sets is
function Strict_Equal (Left, Right : Set) return Boolean is
CuL : Cursor := First (Left);
CuR : Cursor := First (Right);
begin
if Length (Left) /= Length (Right) then
return False;
end if;
while CuL.Node /= 0 or CuR.Node /= 0 loop
if CuL.Node /= CuR.Node or else
Left.Nodes (CuL.Node).Element /=
Right.Nodes (CuR.Node).Element then
if CuL.Node /= CuR.Node
or else Left.Nodes (CuL.Node).Element /=
Right.Nodes (CuR.Node).Element
then
return False;
end if;
CuL := Next (Left, CuL);
CuR := Next (Right, CuR);
end loop;
......@@ -1344,8 +1359,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
procedure Process (Source_Node : Count_Type);
pragma Inline (Process);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process);
procedure Iterate is new HT_Ops.Generic_Iteration (Process);
-------------
-- Process --
......@@ -1355,7 +1369,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
N : Node_Type renames Source.Nodes (Source_Node);
X : Count_Type;
B : Boolean;
begin
if Is_In (Target, N) then
Delete (Target, N.Element);
......@@ -1368,7 +1381,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
-- Start of processing for Symmetric_Difference
begin
if Target'Address = Source'Address then
Clear (Target);
return;
......@@ -1383,8 +1395,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
Iterate (Source);
Iterate (Source);
end Symmetric_Difference;
function Symmetric_Difference (Left, Right : Set) return Set is
......@@ -1406,6 +1418,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
C := Length (Left) + Length (Right);
H := Default_Modulus (C);
return S : Set (C, H) do
Difference (Left, Right, S);
Difference (Right, Left, S);
......@@ -1523,8 +1536,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
return False;
end if;
X := S.Buckets (Element_Keys.Index (S,
N (Position.Node).Element));
X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
for J in 1 .. S.Length loop
if X = Position.Node then
......@@ -1684,7 +1696,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
is
X : Count_Type;
begin
Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
Free (Container, X);
end Exclude;
......@@ -1697,16 +1708,9 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Container : Set;
Key : Key_Type) return Cursor
is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Find;
---------
......@@ -1720,8 +1724,8 @@ package body Ada.Containers.Formal_Hashed_Sets is
"Position cursor has no element";
end if;
pragma Assert (Vet (Container, Position),
"bad cursor in function Key");
pragma Assert
(Vet (Container, Position), "bad cursor in function Key");
declare
N : Node_Type renames Container.Nodes (Position.Node);
......@@ -1739,8 +1743,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
Key : Key_Type;
New_Item : Element_Type)
is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
......@@ -1775,13 +1778,13 @@ package body Ada.Containers.Formal_Hashed_Sets is
(Vet (Container, Position),
"bad cursor in Update_Element_Preserving_Key");
-- Record bucket now, in case key is changed.
-- Record bucket now, in case key is changed
Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
declare
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......@@ -1807,7 +1810,7 @@ package body Ada.Containers.Formal_Hashed_Sets is
end if;
end;
-- Key was modified, so remove this node from set.
-- Key was modified, so remove this node from set
if Container.Buckets (Indx) = Position.Node then
Container.Buckets (Indx) := N (Position.Node).Next;
......
gcc/ada/a-cfhase.ads
......@@ -68,6 +68,7 @@ package Ada.Containers.Formal_Hashed_Sets is
pragma Pure;
type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;
......
gcc/ada/a-cforma.adb
......@@ -43,8 +43,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- These subprograms provide a functional interface to access fields
-- of a node, and a procedural interface for modifying these values.
function Color (Node : Node_Type)
return Ada.Containers.Red_Black_Trees.Color_Type;
function Color
(Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type;
pragma Inline (Color);
function Left_Son (Node : Node_Type) return Count_Type;
......@@ -74,6 +74,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Local Subprograms --
-----------------------
-- All need comments ???
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
......@@ -117,10 +119,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
function "=" (Left, Right : Map) return Boolean is
Lst : Count_Type;
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
if Length (Left) /= Length (Right) then
return False;
end if;
......@@ -130,18 +132,21 @@ package body Ada.Containers.Formal_Ordered_Maps is
end if;
Lst := Next (Left, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
ENode := Find (Right, Left.Nodes (Node).Key).Node;
if ENode = 0 or else
Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
Node := Next (Left, Node);
end loop;
return True;
end "=";
------------
......@@ -167,8 +172,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
function New_Node return Count_Type;
pragma Inline (New_Node);
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node);
procedure Unconditional_Insert_Sans_Hint is
new Key_Ops.Generic_Unconditional_Insert (Insert_Post);
......@@ -178,8 +182,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
(Insert_Post,
Unconditional_Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
......@@ -187,7 +190,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Target, Result);
return Result;
......@@ -218,7 +220,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Start of processing for Assign
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -236,9 +237,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-------------
function Ceiling (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Ceiling (Container, Key);
Node : constant Count_Type := Key_Ops.Ceiling (Container, Key);
begin
if Node = 0 then
......@@ -254,7 +253,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Clear (Container : in out Map) is
begin
Tree_Operations.Clear_Tree (Container);
end Clear;
......@@ -283,6 +281,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Copy (Source : Map; Capacity : Count_Type := 0) return Map is
Node : Count_Type := 1;
N : Count_Type;
begin
return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do
if Length (Source) > 0 then
......@@ -325,7 +324,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete (Container : in out Map; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Delete has no element";
......@@ -340,7 +338,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end Delete;
procedure Delete (Container : in out Map; Key : Key_Type) is
X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
......@@ -358,9 +355,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete_First (Container : in out Map) is
X : constant Node_Access := First (Container).Node;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
......@@ -373,9 +368,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Delete_Last (Container : in out Map) is
X : constant Node_Access := Last (Container).Node;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
......@@ -432,9 +425,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Exclude (Container : in out Map; Key : Key_Type) is
X : constant Node_Access := Key_Ops.Find (Container, Key);
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Maps.Free (Container, X);
......@@ -446,9 +437,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
----------
function Find (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Find (Container, Key);
Node : constant Count_Type := Key_Ops.Find (Container, Key);
begin
if Node = 0 then
......@@ -469,7 +458,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end if;
return (Node => Container.First);
end First;
-------------------
......@@ -503,9 +491,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-----------
function Floor (Container : Map; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Ops.Floor (Container, Key);
Node : constant Count_Type := Key_Ops.Floor (Container, Key);
begin
if Node = 0 then
......@@ -536,10 +522,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type)
is
procedure Allocate is
new Tree_Operations.Generic_Allocate (Set_Element);
begin
Allocate (Tree, Node);
Tree.Nodes (Node).Has_Element := True;
......@@ -596,6 +580,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Inserted : out Boolean)
is
function New_Node return Node_Access;
-- Comment ???
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
......@@ -676,6 +661,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Initialize (Node : in out Node_Type);
procedure Allocate_Node is new Generic_Allocate (Initialize);
----------------
-- Initialize --
----------------
procedure Initialize (Node : in out Node_Type) is
begin
Node.Key := Key;
......@@ -683,6 +672,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
X : Node_Access;
-- Start of processing for New_Node
begin
Allocate_Node (Container, X);
return X;
......@@ -691,11 +682,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Start of processing for Insert
begin
Insert_Sans_Hint
(Container,
Key,
Position.Node,
Inserted);
Insert_Sans_Hint (Container, Key, Position.Node, Inserted);
end Insert;
--------------
......@@ -801,6 +788,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
if Length (Container) = 0 then
return No_Element;
end if;
return (Node => Container.Last);
end Last;
......@@ -836,13 +824,14 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Left (Container : Map; Position : Cursor) return Map is
Curs : Cursor := Position;
C : Map (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
......@@ -852,6 +841,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
......@@ -882,7 +872,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
X : Node_Access;
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -946,20 +935,15 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Overlap (Left, Right : Map) return Boolean is
begin
if Length (Left) = 0 or Length (Right) = 0 then
return False;
end if;
declare
L_Node : Count_Type := First (Left).Node;
R_Node : Count_Type := First (Right).Node;
L_Last : constant Count_Type :=
Next (Left, Last (Left).Node);
R_Last : constant Count_Type :=
Next (Right, Last (Right).Node);
L_Last : constant Count_Type := Next (Left, Last (Left).Node);
R_Last : constant Count_Type := Next (Right, Last (Right).Node);
begin
if Left'Address = Right'Address then
......@@ -973,11 +957,10 @@ package body Ada.Containers.Formal_Ordered_Maps is
return False;
end if;
if Left.Nodes (L_Node).Key
< Right.Nodes (R_Node).Key then
if Left.Nodes (L_Node).Key < Right.Nodes (R_Node).Key then
L_Node := Next (Left, L_Node);
elsif Right.Nodes (R_Node).Key
< Left.Nodes (L_Node).Key then
elsif Right.Nodes (R_Node).Key < Left.Nodes (L_Node).Key then
R_Node := Next (Right, R_Node);
else
......@@ -1052,7 +1035,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Position cursor of Query_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......@@ -1107,8 +1089,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
end Read_Element;
-- Start of processing for Read
begin
begin
Read_Elements (Stream, Container);
end Read;
......@@ -1130,7 +1112,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
New_Item : Element_Type)
is
begin
declare
Node : constant Node_Access := Key_Ops.Find (Container, Key);
......@@ -1163,7 +1144,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Replace_Element has no element";
......@@ -1186,8 +1166,8 @@ package body Ada.Containers.Formal_Ordered_Maps is
procedure Reverse_Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor))
Process : not null access procedure (Container : Map;
Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
......@@ -1213,7 +1193,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
begin
Local_Reverse_Iterate (Container);
exception
when others =>
B := B - 1;
......@@ -1229,13 +1208,14 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Right (Container : Map; Position : Cursor) return Map is
Curs : Cursor := First (Container);
C : Map (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Map (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
......@@ -1246,6 +1226,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
......@@ -1262,10 +1243,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
-- Set_Color --
---------------
procedure Set_Color
(Node : in out Node_Type;
Color : Color_Type)
is
procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is
begin
Node.Color := Color;
end Set_Color;
......@@ -1304,6 +1282,7 @@ package body Ada.Containers.Formal_Ordered_Maps is
function Strict_Equal (Left, Right : Map) return Boolean is
LNode : Count_Type := First (Left).Node;
RNode : Count_Type := First (Right).Node;
begin
if Length (Left) /= Length (Right) then
return False;
......@@ -1314,15 +1293,16 @@ package body Ada.Containers.Formal_Ordered_Maps is
return True;
end if;
if Left.Nodes (LNode).Element /=
Right.Nodes (RNode).Element or
Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key then
if Left.Nodes (LNode).Element /= Right.Nodes (RNode).Element
or else Left.Nodes (LNode).Key /= Right.Nodes (RNode).Key
then
exit;
end if;
LNode := Next (Left, LNode);
RNode := Next (Right, RNode);
end loop;
return False;
end Strict_Equal;
......@@ -1337,7 +1317,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
......@@ -1347,7 +1326,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Position cursor of Update_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......
gcc/ada/a-cforse.adb
......@@ -77,6 +77,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
-- Local Subprograms --
-----------------------
-- Comments needed???
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
......@@ -148,10 +150,10 @@ package body Ada.Containers.Formal_Ordered_Sets is
function "=" (Left, Right : Set) return Boolean is
Lst : Count_Type;
Node : Count_Type := First (Left).Node;
Node : Count_Type;
ENode : Count_Type;
begin
begin
if Length (Left) /= Length (Right) then
return False;
end if;
......@@ -161,18 +163,20 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
Lst := Next (Left, Last (Left).Node);
Node := First (Left).Node;
while Node /= Lst loop
ENode := Find (Right, Left.Nodes (Node).Element).Node;
if ENode = 0 or else
Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
if ENode = 0
or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element
then
return False;
end if;
Node := Next (Left, Node);
end loop;
return True;
end "=";
------------
......@@ -209,8 +213,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
(Insert_Post,
Unconditional_Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
......@@ -218,7 +221,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Target, Result);
return Result;
......@@ -233,6 +235,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node.Element := SN.Element;
end Set_Element;
-- Local variables
Target_Node : Count_Type;
-- Start of processing for Append_Element
......@@ -266,7 +270,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Ceiling (Container : Set; Item : Element_Type) return Cursor is
Node : constant Count_Type := Element_Keys.Ceiling (Container, Item);
begin
......@@ -275,7 +278,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Node);
end Ceiling;
-----------
......@@ -313,9 +315,10 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Copy (Source : Set; Capacity : Count_Type := 0) return Set is
Node : Count_Type := 1;
Node : Count_Type;
N : Count_Type;
Target : Set (Count_Type'Max (Source.Capacity, Capacity));
begin
if Length (Source) > 0 then
Target.Length := Source.Length;
......@@ -324,6 +327,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Target.Last := Source.Last;
Target.Free := Source.Free;
Node := 1;
while Node <= Source.Capacity loop
Target.Nodes (Node).Element :=
Source.Nodes (Node).Element;
......@@ -346,6 +350,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node := Node + 1;
end loop;
end if;
return Target;
end Copy;
......@@ -355,7 +360,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete (Container : in out Set; Position : in out Cursor) is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
......@@ -373,7 +377,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if X = 0 then
raise Constraint_Error with "attempt to delete element not in set";
end if;
......@@ -388,9 +391,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete_First (Container : in out Set) is
X : constant Count_Type := Container.First;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
......@@ -403,9 +404,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Delete_Last (Container : in out Set) is
X : constant Count_Type := Container.Last;
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
......@@ -419,7 +418,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Difference (Target : in out Set; Source : Set) is
begin
Set_Ops.Set_Difference (Target, Source);
end Difference;
function Difference (Left, Right : Set) return Set is
......@@ -437,9 +435,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Length (Left)) do
Assign (S,
Set_Ops.Set_Difference (Left, Right));
Assign (S, Set_Ops.Set_Difference (Left, Right));
end return;
end Difference;
......@@ -517,9 +513,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Exclude (Container : in out Set; Item : Element_Type) is
X : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if X /= 0 then
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
......@@ -531,9 +525,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Find (Container : Set; Item : Element_Type) return Cursor is
Node : constant Count_Type :=
Element_Keys.Find (Container, Item);
Node : constant Count_Type := Element_Keys.Find (Container, Item);
begin
if Node = 0 then
......@@ -541,7 +533,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Node);
end Find;
-----------
......@@ -555,7 +546,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return (Node => Container.First);
end First;
-------------------
......@@ -582,10 +572,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Floor (Container : Set; Item : Element_Type) return Cursor is
begin
declare
Node : constant Count_Type :=
Element_Keys.Floor (Container, Item);
Node : constant Count_Type := Element_Keys.Floor (Container, Item);
begin
if Node = 0 then
......@@ -600,10 +588,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-- Free --
----------
procedure Free
(Tree : in out Set;
X : Count_Type)
is
procedure Free (Tree : in out Set; X : Count_Type) is
begin
Tree.Nodes (X).Has_Element := False;
Tree_Operations.Free (Tree, X);
......@@ -617,10 +602,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
(Tree : in out Tree_Types.Tree_Type'Class;
Node : out Count_Type)
is
procedure Allocate is
new Tree_Operations.Generic_Allocate (Set_Element);
begin
Allocate (Tree, Node);
Tree.Nodes (Node).Has_Element := True;
......@@ -662,8 +645,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Ceiling (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Keys.Ceiling (Container, Key);
Node : constant Count_Type := Key_Keys.Ceiling (Container, Key);
begin
if Node = 0 then
......@@ -687,7 +669,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
------------
procedure Delete (Container : in out Set; Key : Key_Type) is
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
......@@ -704,8 +685,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
function Element (Container : Set; Key : Key_Type) return Element_Type is
Node : constant Count_Type :=
Key_Keys.Find (Container, Key);
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
......@@ -739,9 +719,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
procedure Exclude (Container : in out Set; Key : Key_Type) is
X : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if X /= 0 then
Delete_Node_Sans_Free (Container, X);
......@@ -754,15 +732,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
----------
function Find (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Find;
-----------
......@@ -770,17 +742,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
-----------
function Floor (Container : Set; Key : Key_Type) return Cursor is
Node : constant Count_Type :=
Key_Keys.Floor (Container, Key);
Node : constant Count_Type := Key_Keys.Floor (Container, Key);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end Floor;
-------------------------
......@@ -838,15 +802,13 @@ package body Ada.Containers.Formal_Ordered_Sets is
New_Item : Element_Type)
is
Node : constant Count_Type := Key_Keys.Find (Container, Key);
begin
if not Has_Element (Container, (Node => Node)) then
raise Constraint_Error with
"attempt to replace key not in set";
end if;
else
Replace_Element (Container, Node, New_Item);
end if;
end Replace;
-----------------------------------
......@@ -859,7 +821,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process : not null access procedure (Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
......@@ -918,9 +879,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
begin
if Position.Node = 0 then
return False;
end if;
else
return Container.Nodes (Position.Node).Has_Element;
end if;
end Has_Element;
-------------
......@@ -959,13 +920,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Inserted : out Boolean)
is
begin
Insert_Sans_Hint
(Container,
New_Item,
Position.Node,
Inserted);
Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted);
end Insert;
procedure Insert
......@@ -994,7 +949,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Node : out Count_Type;
Inserted : out Boolean)
is
procedure Set_Element (Node : in out Node_Type);
function New_Node return Count_Type;
......@@ -1006,8 +960,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Conditional_Insert_Sans_Hint is
new Element_Keys.Generic_Conditional_Insert (Insert_Post);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
......@@ -1015,7 +968,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Container, Result);
return Result;
......@@ -1066,11 +1018,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Local_Insert_With_Hint is
new Element_Keys.Generic_Conditional_Insert_With_Hint
(Insert_Post,
Insert_Sans_Hint);
(Insert_Post, Insert_Sans_Hint);
procedure Allocate is
new Generic_Allocate (Set_Element);
procedure Allocate is new Generic_Allocate (Set_Element);
--------------
-- New_Node --
......@@ -1078,7 +1028,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Dst_Set, Result);
return Result;
......@@ -1120,8 +1069,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Count_Type'Min (Length (Left), Length (Right))) do
Assign (S, Set_Ops.Set_Intersection
(Left, Right));
Assign (S, Set_Ops.Set_Intersection (Left, Right));
end return;
end Intersection;
......@@ -1175,8 +1123,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
begin
return Set_Ops.Set_Subset (Subset,
Of_Set => Of_Set);
return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
end Is_Subset;
-------------
......@@ -1185,8 +1132,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor))
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
......@@ -1203,6 +1150,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process (Container, (Node => Node));
end Process_Node;
-- Local variables
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of prccessing for Iterate
......@@ -1227,12 +1176,9 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Last (Container : Set) return Cursor is
begin
if Length (Container) = 0 then
return No_Element;
end if;
return (Node => Container.Last);
return (if Length (Container) = 0
then No_Element
else (Node => Container.Last));
end Last;
------------------
......@@ -1258,13 +1204,14 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Left (Container : Set; Position : Cursor) return Set is
Curs : Cursor := Position;
C : Set (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
return C;
end if;
if not Has_Element (Container, Curs) then
raise Constraint_Error;
end if;
......@@ -1274,6 +1221,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Left;
......@@ -1304,7 +1252,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
X : Count_Type;
begin
if Target'Address = Source'Address then
return;
end if;
......@@ -1363,7 +1310,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Overlap (Left, Right : Set) return Boolean is
begin
return Set_Ops.Set_Overlap (Left, Right);
end Overlap;
------------
......@@ -1395,13 +1341,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
declare
Node : constant Count_Type :=
Tree_Operations.Previous (Container, Position.Node);
begin
if Node = 0 then
return No_Element;
end if;
return (Node => Node);
return (if Node = 0 then No_Element else (Node => Node));
end;
end Previous;
......@@ -1420,7 +1361,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Process : not null access procedure (Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
......@@ -1429,7 +1369,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
"bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
......@@ -1478,8 +1417,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
end Read_Element;
-- Start of processing for Read
begin
begin
Read_Elements (Stream, Container);
end Read;
......@@ -1496,9 +1435,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
-------------
procedure Replace (Container : in out Set; New_Item : Element_Type) is
Node : constant Count_Type :=
Element_Keys.Find (Container, New_Item);
Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
begin
if Node = 0 then
......@@ -1547,14 +1484,12 @@ package body Ada.Containers.Formal_Ordered_Sets is
function New_Node return Count_Type is
N : Node_Type renames NN (Node);
begin
N.Element := Item;
N.Color := Red;
N.Parent := 0;
N.Right := 0;
N.Left := 0;
return Node;
end New_Node;
......@@ -1620,7 +1555,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
New_Item : Element_Type)
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
......@@ -1638,8 +1572,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
procedure Reverse_Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor))
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
......@@ -1680,14 +1614,15 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Right (Container : Set; Position : Cursor) return Set is
Curs : Cursor := First (Container);
C : Set (Container.Capacity) :=
Copy (Container, Container.Capacity);
C : Set (Container.Capacity) := Copy (Container, Container.Capacity);
Node : Count_Type;
begin
if Curs = No_Element then
Clear (C);
return C;
end if;
if Position /= No_Element and not Has_Element (Container, Position) then
raise Constraint_Error;
end if;
......@@ -1697,6 +1632,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
Delete (C, Curs);
Curs := Next (Container, (Node => Node));
end loop;
return C;
end Right;
......@@ -1755,6 +1691,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
function Strict_Equal (Left, Right : Set) return Boolean is
LNode : Count_Type := First (Left).Node;
RNode : Count_Type := First (Right).Node;
begin
if Length (Left) /= Length (Right) then
return False;
......@@ -1773,8 +1710,8 @@ package body Ada.Containers.Formal_Ordered_Sets is
LNode := Next (Left, LNode);
RNode := Next (Right, RNode);
end loop;
return False;
return False;
end Strict_Equal;
--------------------------
......@@ -1801,9 +1738,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
return S : Set (Length (Left) + Length (Right)) do
Assign (S,
Set_Ops.Set_Symmetric_Difference (Left,
Right));
Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right));
end return;
end Symmetric_Difference;
......@@ -1814,7 +1749,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
function To_Set (New_Item : Element_Type) return Set is
Node : Count_Type;
Inserted : Boolean;
begin
return S : Set (Capacity => 1) do
Insert_Sans_Hint (S, New_Item, Node, Inserted);
......
gcc/ada/a-cforse.ads
......@@ -67,6 +67,7 @@ package Ada.Containers.Formal_Ordered_Sets is
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
type Set (Capacity : Count_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
type Cursor is private;
......
gcc/ada/a-except-2005.adb
......@@ -895,9 +895,11 @@ package body Ada.Exceptions is
Prefix : constant String := "adjust/finalize raised ";
Orig_Msg : constant String := Exception_Message (X);
Orig_Prefix_Length : constant Natural :=
Integer'Min (Prefix'Length, Orig_Msg'Length);
Integer'Min
(Prefix'Length, Orig_Msg'Length);
Orig_Prefix : String renames Orig_Msg
(Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
(Orig_Msg'First ..
Orig_Msg'First + Orig_Prefix_Length - 1);
begin
-- Message already has the proper prefix, just re-raise
......
gcc/ada/alfa.adb
......@@ -23,8 +23,10 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Output; use Output;
with Put_ALFA;
with Sinfo; use Sinfo;
package body ALFA is
......@@ -153,6 +155,74 @@ package body ALFA is
ALFA_Xref_Table.Init;
end Initialize_ALFA_Tables;
-------------------------
-- Get_Entity_For_Decl --
-------------------------
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Subprogram_Body |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Defining_Unit_Name (N);
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Entity_For_Decl;
--------------------------------
-- Get_Unique_Entity_For_Decl --
--------------------------------
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id is
E : Entity_Id := Empty;
begin
case Nkind (N) is
when N_Subprogram_Declaration |
N_Package_Declaration =>
E := Defining_Unit_Name (Specification (N));
when N_Package_Body =>
E := Corresponding_Spec (N);
when N_Subprogram_Body =>
if Acts_As_Spec (N) then
E := Defining_Unit_Name (Specification (N));
else
E := Corresponding_Spec (N);
end if;
when N_Object_Declaration =>
E := Defining_Identifier (N);
when others =>
null;
end case;
if Nkind (E) = N_Defining_Program_Unit_Name then
E := Defining_Identifier (E);
end if;
return E;
end Get_Unique_Entity_For_Decl;
-----------
-- palfa --
-----------
......
gcc/ada/alfa.ads
......@@ -323,6 +323,13 @@ package ALFA is
procedure Initialize_ALFA_Tables;
-- Reset tables for a new compilation
function Get_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity for declaration N
function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id;
-- Return the entity which represents declaration N, so that matching
-- declaration and body have the same entity.
procedure palfa;
-- Debugging procedure to output contents of ALFA binary tables in the
-- format in which they appear in an ALI file.
......
gcc/ada/einfo.adb
......@@ -521,7 +521,7 @@ package body Einfo is
-- Body_Is_In_ALFA Flag251
-- Is_Processed_Transient Flag252
-- (unused) Flag253
-- Is_Postcondition_Proc Flag253
-- (unused) Flag254
-----------------------
......@@ -1976,6 +1976,12 @@ package body Einfo is
return Flag138 (Id);
end Is_Packed_Array_Type;
function Is_Postcondition_Proc (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Procedure);
return Flag253 (Id);
end Is_Postcondition_Proc;
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -4494,6 +4500,12 @@ package body Einfo is
Set_Flag138 (Id, V);
end Set_Is_Packed_Array_Type;
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag253 (Id, V);
end Set_Is_Postcondition_Proc;
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
......@@ -7563,6 +7575,7 @@ package body Einfo is
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
W ("Is_Postcondition_Proc", Flag253 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Preelaborated", Flag59 (Id));
W ("Is_Primitive", Flag218 (Id));
......
gcc/ada/einfo.ads
......@@ -2563,6 +2563,10 @@ package Einfo is
-- an entity, then the Original_Array_Type field of this entity points
-- to the original array type for which this is the packed array type.
-- Is_Postcondition_Proc (Flag253)
-- Present in procedures. Set if entity is a procedure generated by the
-- compiler for a postcondition.
-- Is_Potentially_Use_Visible (Flag9)
-- Present in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
......@@ -5521,6 +5525,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
-- Is_Postcondition_Proc (Flag253) (non-generic case only)
-- Is_Primitive (Flag218)
-- Is_Primitive_Wrapper (Flag195) (non-generic case only)
-- Is_Private_Descendant (Flag53)
......@@ -6213,6 +6218,7 @@ package Einfo is
function Is_Package_Body_Entity (Id : E) return B;
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Type (Id : E) return B;
function Is_Postcondition_Proc (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
function Is_Primitive (Id : E) return B;
......@@ -6807,6 +6813,7 @@ package Einfo is
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
procedure Set_Is_Postcondition_Proc (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Preelaborated (Id : E; V : B := True);
procedure Set_Is_Primitive (Id : E; V : B := True);
......@@ -7535,6 +7542,7 @@ package Einfo is
pragma Inline (Is_Overloadable);
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Postcondition_Proc);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Preelaborated);
pragma Inline (Is_Primitive);
......@@ -7946,6 +7954,7 @@ package Einfo is
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Type);
pragma Inline (Set_Is_Postcondition_Proc);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Preelaborated);
pragma Inline (Set_Is_Primitive);
......
gcc/ada/get_scos.adb
......@@ -307,7 +307,7 @@ begin
-- Decision entry
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Dtyp := C;
Skip_Spaces;
......
gcc/ada/par_sco.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -126,7 +126,8 @@ package body Par_SCO is
procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
procedure Traverse_Package_Body (N : Node_Id);
procedure Traverse_Package_Declaration (N : Node_Id);
procedure Traverse_Subprogram_Body (N : Node_Id);
procedure Traverse_Protected_Body (N : Node_Id);
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id);
procedure Traverse_Subprogram_Declaration (N : Node_Id);
-- Traverse the corresponding construct, generating SCO table entries
......@@ -439,6 +440,9 @@ package body Par_SCO is
-------------------
procedure Output_Header (T : Character) is
Loc : Source_Ptr := No_Location;
-- Node whose sloc is used for the decision
begin
case T is
when 'I' | 'E' | 'W' =>
......@@ -446,55 +450,47 @@ package body Par_SCO is
-- For IF, EXIT, WHILE, the token SLOC can be found from
-- the SLOC of the parent of the expression.
Set_Table_Entry
(C1 => T,
C2 => ' ',
From => Sloc (Parent (N)),
To => No_Location,
Last => False);
Loc := Sloc (Parent (N));
when 'P' =>
when 'G' | 'P' =>
-- For entry, the token sloc is from the N_Entry_Body.
-- For PRAGMA, we must get the location from the pragma node.
-- Argument N is the pragma argument, and we have to go up two
-- levels (through the pragma argument association) to get to
-- the pragma node itself.
declare
Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
Loc := Sloc (Parent (Parent (N)));
begin
Set_Table_Entry
(C1 => 'P',
C2 => 'd',
From => Loc,
To => No_Location,
Last => False);
when 'X' =>
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled above, the call will change C2 to 'e'
-- to enable the pragma header entry.
-- For an expression, no Sloc
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end;
null;
when 'X' =>
-- No other possibilities
-- For an expression, no Sloc
when others =>
raise Program_Error;
end case;
Set_Table_Entry
(C1 => 'X',
(C1 => T,
C2 => ' ',
From => No_Location,
From => Loc,
To => No_Location,
Last => False);
-- No other possibilities
if T = 'P' then
-- For pragmas we also must make an entry in the hash table
-- for later access by Set_SCO_Pragma_Enabled. We set the
-- pragma as disabled now, the call will change C2 to 'e'
-- to enable the pragma header entry.
SCO_Table.Table (SCO_Table.Last).C2 := 'd';
Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
end if;
when others =>
raise Program_Error;
end case;
end Output_Header;
------------------------------
......@@ -773,30 +769,34 @@ package body Par_SCO is
-- Traverse the unit
if Nkind (Lu) = N_Subprogram_Body then
Traverse_Subprogram_Body (Lu);
case Nkind (Lu) is
when N_Protected_Body =>
Traverse_Protected_Body (Lu);
elsif Nkind (Lu) = N_Subprogram_Declaration then
when N_Subprogram_Body | N_Task_Body =>
Traverse_Subprogram_Or_Task_Body (Lu);
when N_Subprogram_Declaration =>
Traverse_Subprogram_Declaration (Lu);
elsif Nkind (Lu) = N_Package_Declaration then
when N_Package_Declaration =>
Traverse_Package_Declaration (Lu);
elsif Nkind (Lu) = N_Package_Body then
when N_Package_Body =>
Traverse_Package_Body (Lu);
elsif Nkind (Lu) = N_Generic_Package_Declaration then
when N_Generic_Package_Declaration =>
Traverse_Generic_Package_Declaration (Lu);
elsif Nkind (Lu) in N_Generic_Instantiation then
when N_Generic_Instantiation =>
Traverse_Generic_Instantiation (Lu);
when others =>
-- All other cases of compilation units (e.g. renamings), generate
-- no SCO information.
else
null;
end if;
end case;
-- Make entry for new unit in unit tables, we will fill in the file
-- name and dependency numbers later.
......@@ -1144,11 +1144,31 @@ package body Par_SCO is
(Parameter_Specifications (Specification (N)), 'X');
Set_Statement_Entry;
-- Subprogram_Body
-- Task or subprogram body
when N_Subprogram_Body =>
when N_Task_Body | N_Subprogram_Body =>
Set_Statement_Entry;
Traverse_Subprogram_Body (N);
Traverse_Subprogram_Or_Task_Body (N);
-- Entry body
when N_Entry_Body =>
declare
Cond : constant Node_Id :=
Condition (Entry_Body_Formal_Part (N));
begin
Set_Statement_Entry;
if Present (Cond) then
Process_Decisions_Defer (Cond, 'G');
end if;
Traverse_Subprogram_Or_Task_Body (N);
end;
-- Protected body
when N_Protected_Body =>
Set_Statement_Entry;
Traverse_Protected_Body (N);
-- Exit statement, which is an exit statement in the SCO sense,
-- so it is included in the current statement sequence, but
......@@ -1485,15 +1505,24 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
end Traverse_Package_Declaration;
------------------------------
-- Traverse_Subprogram_Body --
------------------------------
-----------------------------
-- Traverse_Protected_Body --
-----------------------------
procedure Traverse_Protected_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
end Traverse_Protected_Body;
--------------------------------------
-- Traverse_Subprogram_Or_Task_Body --
--------------------------------------
procedure Traverse_Subprogram_Body (N : Node_Id) is
procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
begin
Traverse_Declarations_Or_Statements (Declarations (N));
Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
end Traverse_Subprogram_Body;
end Traverse_Subprogram_Or_Task_Body;
-------------------------------------
-- Traverse_Subprogram_Declaration --
......
gcc/ada/put_scos.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -142,7 +142,7 @@ begin
-- Decision
when 'I' | 'E' | 'P' | 'W' | 'X' =>
when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
Start := Start + 1;
-- For disabled pragma, skip decision output
......
gcc/ada/scos.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2009-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2011, 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- --
......@@ -228,12 +228,13 @@ package SCOs is
-- I decision in IF statement or conditional expression
-- E decision in EXIT WHEN statement
-- G decision in entry guard
-- P decision in pragma Assert/Check/Pre_Condition/Post_Condition
-- W decision in WHILE iteration scheme
-- X decision appearing in some other expression context
-- For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or
-- WHILE token.
-- For I, E, G, P, W, sloc is the source location of the IF, EXIT,
-- ENTRY, PRAGMA or WHILE token, respectively
-- For X, sloc is omitted
......
gcc/ada/sem_ch6.adb
......@@ -9550,6 +9550,9 @@ package body Sem_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Plist)));
Set_Ekind (Post_Proc, E_Procedure);
Set_Is_Postcondition_Proc (Post_Proc);
-- If this is a procedure, set the Postcondition_Proc attribute on
-- the proper defining entity for the subprogram.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment