diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-08-03 17:12:06 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-08-03 17:12:06 +0200 |
| commit | 5ffe0bab81981655b009617fc7041a818fee1d89 (patch) | |
| tree | c3e1b37787cbc0bbe2f029504a32efa76e9d5ecd | |
| parent | f9ad6b6231baeb79e967d1e7f1d1d9a7953453b7 (diff) | |
| download | gcc-5ffe0bab81981655b009617fc7041a818fee1d89.zip gcc-5ffe0bab81981655b009617fc7041a818fee1d89.tar.gz gcc-5ffe0bab81981655b009617fc7041a818fee1d89.tar.bz2 | |
[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
| -rw-r--r-- | gcc/ada/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/ada/a-cfhama.adb | 136 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.adb | 197 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/a-cforma.adb | 142 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.adb | 230 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/alfa.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/alfa.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/get_scos.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 145 | ||||
| -rw-r--r-- | gcc/ada/put_scos.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/scos.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 3 |
17 files changed, 562 insertions, 460 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e025e2b..fb01723 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +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 diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index 5bcafe2..f2d670c 100644 --- a/gcc/ada/a-cfhama.adb +++ b/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; @@ -73,10 +75,10 @@ package body Ada.Containers.Formal_Hashed_Maps is package HT_Ops is new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); package Key_Ops is new Hash_Tables.Generic_Bounded_Keys @@ -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 @@ -399,7 +408,7 @@ package body Ada.Containers.Formal_Hashed_Maps is function Find (Container : Map; Key : Key_Type) return Cursor is Node : constant Count_Type := - Key_Ops.Find (Container, Key); + Key_Ops.Find (Container, Key); begin if Node = 0 then @@ -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; @@ -551,7 +555,7 @@ package body Ada.Containers.Formal_Hashed_Maps is return Result; end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert begin @@ -598,10 +602,9 @@ package body Ada.Containers.Formal_Hashed_Maps is return Result; end New_Node; - -- Start of processing for Insert + -- 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); @@ -658,7 +661,7 @@ package body Ada.Containers.Formal_Hashed_Maps is B : Natural renames Container'Unrestricted_Access.Busy; - -- Start of processing for Iterate + -- Start of processing for Iterate begin B := B + 1; @@ -695,14 +698,18 @@ package body Ada.Containers.Formal_Hashed_Maps is ---------- function Left (Container : Map; Position : Cursor) return Map is - Curs : Cursor := Position; - C : Map (Container.Capacity, Container.Modulus) := - Copy (Container, Container.Capacity); + 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; @@ -852,10 +858,9 @@ package body Ada.Containers.Formal_Hashed_Maps is (Container : in out Map; Position : Cursor; Process : not null access - procedure (Key : Key_Type; Element : Element_Type)) + 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"; @@ -864,8 +869,7 @@ package body Ada.Containers.Formal_Hashed_Maps is pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); declare - N : Node_Type renames Container.Nodes (Position.Node); - + 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); @@ -925,14 +928,15 @@ package body Ada.Containers.Formal_Hashed_Maps is Node : Count_Type; - -- Start of processing for Read_Node + -- Start of processing for Read_Node begin Allocate (Container, Node); return Node; end Read_Node; - -- Start of processing for Read + -- 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; @@ -1024,14 +1025,16 @@ package body Ada.Containers.Formal_Hashed_Maps is function Right (Container : Map; Position : Cursor) return Map is Curs : Cursor := First (Container); - C : Map (Container.Capacity, Container.Modulus) := - Copy (Container, Container.Capacity); + 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; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 2a79b04..164433e 100644 --- a/gcc/ada/a-cfhase.adb +++ b/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,14 +128,15 @@ 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; - if ENode = 0 or else + if ENode = 0 or else Right.Nodes (ENode).Element /= Left.Nodes (Node).Element then return False; @@ -173,10 +175,9 @@ package body Ada.Containers.Formal_Hashed_Sets is pragma Assert (B); end Insert_Element; - -- Start of processing for Assign + -- 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; @@ -226,28 +226,34 @@ package body Ada.Containers.Formal_Hashed_Sets is Capacity : Count_Type := 0) return Set is C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - H : Hash_Type := 1; - N : Count_Type := 1; + Count_Type'Max (Capacity, Source.Capacity); + 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); @@ -394,7 +397,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; end Process; - -- Start of processing for Difference + -- Start of processing for Difference begin Iterate (Left); @@ -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"; @@ -464,10 +470,8 @@ package body Ada.Containers.Formal_Hashed_Sets is L_Node : Node_Type) return Boolean is R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - + 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 @@ -485,7 +489,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end loop; end Find_Equivalent_Key; - -- Start of processing of Equivalent_Sets + -- Start of processing of Equivalent_Sets begin return Is_Equivalent (Left, Right); @@ -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; @@ -767,12 +777,10 @@ package body Ada.Containers.Formal_Hashed_Sets is return Result; end New_Node; - -- Start of processing for Insert + -- 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; @@ -845,7 +852,7 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; end Process; - -- Start of processing for Intersection + -- Start of processing for Intersection begin Iterate (Left); @@ -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); @@ -949,7 +956,7 @@ package body Ada.Containers.Formal_Hashed_Sets is B : Natural renames Container'Unrestricted_Access.Busy; - -- Start of processing for Iterate + -- Start of processing for Iterate begin B := B + 1; @@ -971,13 +978,15 @@ package body Ada.Containers.Formal_Hashed_Sets is function Left (Container : Set; Position : Cursor) return Set is Curs : Cursor := Position; - C : Set (Container.Capacity, Container.Modulus) := - Copy (Container, Container.Capacity); + 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 @@ -1181,16 +1193,16 @@ package body Ada.Containers.Formal_Hashed_Sets is Node : Count_Type; - -- Start of processing for Read_Node + -- Start of processing for Read_Node begin Allocate (Container, Node); return Node; end Read_Node; - -- Start of processing for Read - begin + -- Start of processing for Read + 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"; @@ -1270,14 +1279,16 @@ package body Ada.Containers.Formal_Hashed_Sets is function Right (Container : Set; Position : Cursor) return Set is Curs : Cursor := First (Container); - C : Set (Container.Capacity, Container.Modulus) := - Copy (Container, Container.Capacity); + 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); @@ -1365,10 +1378,9 @@ package body Ada.Containers.Formal_Hashed_Sets is end if; end Process; - -- Start of processing for Symmetric_Difference + -- 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 @@ -1759,7 +1762,7 @@ package body Ada.Containers.Formal_Hashed_Sets is (Container : in out Set; Position : Cursor; Process : not null access - procedure (Element : in out Element_Type)) + procedure (Element : in out Element_Type)) is Indx : Hash_Type; N : Nodes_Type renames Container.Nodes; @@ -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; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index ea77968..ad6c72f 100644 --- a/gcc/ada/a-cfhase.ads +++ b/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; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index ecd8de5..d102a3d 100644 --- a/gcc/ada/a-cforma.adb +++ b/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 @@ -99,8 +101,8 @@ package body Ada.Containers.Formal_Ordered_Maps is package Tree_Operations is new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types => Tree_Types, - Left => Left_Son, - Right => Right_Son); + Left => Left_Son, + Right => Right_Son); use Tree_Operations; @@ -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,19 +172,17 @@ 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); + new Key_Ops.Generic_Unconditional_Insert (Insert_Post); procedure Unconditional_Insert_Avec_Hint is - new Key_Ops.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); + new Key_Ops.Generic_Unconditional_Insert_With_Hint + (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); @@ -624,7 +609,7 @@ package body Ada.Containers.Formal_Ordered_Maps is return X; end New_Node; - -- Start of processing for Insert + -- Start of processing for Insert begin Insert_Sans_Hint @@ -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,19 +672,17 @@ package body Ada.Containers.Formal_Ordered_Maps is X : Node_Access; + -- Start of processing for New_Node + begin Allocate_Node (Container, X); return X; end New_Node; - -- Start of processing for Insert + -- 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; @@ -904,7 +893,7 @@ package body Ada.Containers.Formal_Ordered_Maps is exit when X = 0; -- Here we insert a copy of the source element into the target, and - -- then delete the element from the source. Another possibility is + -- then delete the element from the source. Another possibility is -- that delete it first (and hang onto its index), then insert it. -- ??? @@ -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_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); 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; @@ -1106,9 +1088,9 @@ package body Ada.Containers.Formal_Ordered_Maps is Element_Type'Read (Stream, Node.Element); end Read_Element; - -- Start of processing for Read - begin + -- Start of processing for Read + 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); @@ -1206,14 +1186,13 @@ package body Ada.Containers.Formal_Ordered_Maps is B : Natural renames Container'Unrestricted_Access.Busy; - -- Start of processing for Reverse_Iterate + -- Start of processing for Reverse_Iterate begin B := B + 1; 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; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 59f4efe..794b47b 100644 --- a/gcc/ada/a-cforse.adb +++ b/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 @@ -122,8 +124,8 @@ package body Ada.Containers.Formal_Ordered_Sets is package Tree_Operations is new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types, - Left => Left_Son, - Right => Right_Son); + Left => Left_Son, + Right => Right_Son); use Tree_Operations; @@ -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 "="; ------------ @@ -206,11 +210,10 @@ package body Ada.Containers.Formal_Ordered_Sets is procedure Unconditional_Insert_Avec_Hint is new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); + (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,9 +235,11 @@ 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 + -- Start of processing for Append_Element begin Unconditional_Insert_Avec_Hint @@ -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,17 +315,19 @@ package body Ada.Containers.Formal_Ordered_Sets is ---------- function Copy (Source : Set; Capacity : Count_Type := 0) return Set is - Node : Count_Type := 1; - N : Count_Type; + Node : Count_Type; + N : Count_Type; Target : Set (Count_Type'Max (Source.Capacity, Capacity)); + begin if Length (Source) > 0 then Target.Length := Source.Length; - Target.Root := Source.Root; - Target.First := Source.First; - Target.Last := Source.Last; - Target.Free := Source.Free; + Target.Root := Source.Root; + Target.First := Source.First; + 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; @@ -484,7 +480,7 @@ package body Ada.Containers.Formal_Ordered_Sets is function Equivalent_Sets (Left, Right : Set) return Boolean is function Is_Equivalent_Node_Node - (L, R : Node_Type) return Boolean; + (L, R : Node_Type) return Boolean; pragma Inline (Is_Equivalent_Node_Node); function Is_Equivalent is @@ -505,7 +501,7 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; end Is_Equivalent_Node_Node; - -- Start of processing for Equivalent_Sets + -- Start of processing for Equivalent_Sets begin return Is_Equivalent (Left, Right); @@ -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"; + else + Replace_Element (Container, Node, New_Item); end if; - - Replace_Element (Container, Node, New_Item); 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; + else + return Container.Nodes (Position.Node).Has_Element; end if; - - return Container.Nodes (Position.Node).Has_Element; 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; @@ -1030,7 +982,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Node.Element := New_Item; end Set_Element; - -- Start of processing for Insert_Sans_Hint + -- Start of processing for Insert_Sans_Hint begin Conditional_Insert_Sans_Hint @@ -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; @@ -1093,7 +1042,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Node.Element := Src_Node.Element; end Set_Element; - -- Start of processing for Insert_With_Hint + -- Start of processing for Insert_With_Hint begin Local_Insert_With_Hint @@ -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,9 +1150,11 @@ 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 + -- Start of prccessing for Iterate begin B := B + 1; @@ -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; ------------ @@ -1394,14 +1340,9 @@ package body Ada.Containers.Formal_Ordered_Sets is declare Node : constant Count_Type := - Tree_Operations.Previous (Container, Position.Node); - + 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; @@ -1477,9 +1416,9 @@ package body Ada.Containers.Formal_Ordered_Sets is Element_Type'Read (Stream, Node.Element); end Read_Element; - -- Start of processing for Read - begin + -- Start of processing for Read + 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; - + N.Color := Red; + N.Parent := 0; + N.Right := 0; + N.Left := 0; return Node; end New_Node; @@ -1562,7 +1497,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Result : Count_Type; Inserted : Boolean; - -- Start of processing for Insert + -- Start of processing for Insert begin if Item < NN (Node).Element @@ -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); @@ -1658,7 +1592,7 @@ package body Ada.Containers.Formal_Ordered_Sets is B : Natural renames Container'Unrestricted_Access.Busy; - -- Start of processing for Reverse_Iterate + -- Start of processing for Reverse_Iterate begin B := B + 1; @@ -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); @@ -1879,7 +1813,7 @@ package body Ada.Containers.Formal_Ordered_Sets is Element_Type'Write (Stream, Node.Element); end Write_Element; - -- Start of processing for Write + -- Start of processing for Write begin Write_Elements (Stream, Container); diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index acca6b9..03203cd 100644 --- a/gcc/ada/a-cforse.ads +++ b/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; @@ -276,7 +277,7 @@ private new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); type Set (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; + new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; use Ada.Streams; diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 3ee4098..3b72130 100644 --- a/gcc/ada/a-except-2005.adb +++ b/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 diff --git a/gcc/ada/alfa.adb b/gcc/ada/alfa.adb index 6fd1d8f..9030d00 100644 --- a/gcc/ada/alfa.adb +++ b/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 -- ----------- diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads index ec171bb..1813a79 100644 --- a/gcc/ada/alfa.ads +++ b/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. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 9478ae3..e1b63f0 100644 --- a/gcc/ada/einfo.adb +++ b/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)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3fa3751..0bc2e38 100644 --- a/gcc/ada/einfo.ads +++ b/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); diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb index 7a90959..7ee46b3 100644 --- a/gcc/ada/get_scos.adb +++ b/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; diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index 251c6e2..67076f5 100644 --- a/gcc/ada/par_sco.adb +++ b/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))); - - begin - Set_Table_Entry - (C1 => 'P', - C2 => 'd', - From => Loc, - To => No_Location, - Last => False); - - -- 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. - - Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last); - end; + Loc := Sloc (Parent (Parent (N))); when 'X' => -- For an expression, no Sloc - Set_Table_Entry - (C1 => 'X', - C2 => ' ', - From => No_Location, - To => No_Location, - Last => False); + null; -- No other possibilities when others => raise Program_Error; end case; + + Set_Table_Entry + (C1 => T, + C2 => ' ', + From => Loc, + To => No_Location, + Last => False); + + 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; + 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 - Traverse_Subprogram_Declaration (Lu); + when N_Subprogram_Body | N_Task_Body => + Traverse_Subprogram_Or_Task_Body (Lu); - elsif Nkind (Lu) = N_Package_Declaration then - Traverse_Package_Declaration (Lu); + when N_Subprogram_Declaration => + Traverse_Subprogram_Declaration (Lu); - elsif Nkind (Lu) = N_Package_Body then - Traverse_Package_Body (Lu); + when N_Package_Declaration => + Traverse_Package_Declaration (Lu); - elsif Nkind (Lu) = N_Generic_Package_Declaration then - Traverse_Generic_Package_Declaration (Lu); + when N_Package_Body => + Traverse_Package_Body (Lu); - elsif Nkind (Lu) in N_Generic_Instantiation then - Traverse_Generic_Instantiation (Lu); + when N_Generic_Package_Declaration => + Traverse_Generic_Package_Declaration (Lu); - -- All other cases of compilation units (e.g. renamings), generate - -- no SCO information. + when N_Generic_Instantiation => + Traverse_Generic_Instantiation (Lu); - else - null; - end if; + when others => + -- All other cases of compilation units (e.g. renamings), generate + -- no SCO information. + + null; + 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_Task_Body | N_Subprogram_Body => + Set_Statement_Entry; + 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_Subprogram_Body => + when N_Protected_Body => Set_Statement_Entry; - Traverse_Subprogram_Body (N); + 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 -- diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index 9d3bcd7..6154abb 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P U T _ S C O S -- +-- P U T _ S C O S -- -- -- -- 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 diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads index 40a278e..ea16370 100644 --- a/gcc/ada/scos.ads +++ b/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 diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3169111..ebc1c71 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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. |