diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 38 | ||||
| -rw-r--r-- | gcc/ada/a-cfhama.adb | 304 | ||||
| -rw-r--r-- | gcc/ada/a-cfhama.ads | 63 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.adb | 307 | ||||
| -rw-r--r-- | gcc/ada/a-cfhase.ads | 47 | ||||
| -rw-r--r-- | gcc/ada/a-cforma.adb | 332 | ||||
| -rw-r--r-- | gcc/ada/a-cforma.ads | 59 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.adb | 294 | ||||
| -rw-r--r-- | gcc/ada/a-cforse.ads | 52 | ||||
| -rw-r--r-- | gcc/ada/a-cofove.adb | 409 | ||||
| -rw-r--r-- | gcc/ada/a-cofove.ads | 115 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 101 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 6 |
17 files changed, 168 insertions, 2008 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 69141c3f243..bb90af88a38 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2013-04-25 Hristian Kirtchev <kirtchev@adacore.com> + + * checks.adb (Apply_Predicate_Check): Update the comment associated + with the call to Check_Expression_Against_Static_Predicate. + * sem_ch3.adb (Analyze_Object_Declaration): Update the comment + associated with the call to Check_Expression_Against_Static_Predicate. + * sem_util.adb (Check_Expression_Against_Static_Predicate): + Broaden the check from a static expression to an expression with + a known value at compile time. + * sem_util.ads (Check_Expression_Against_Static_Predicate): Update + comment on usage. + +2013-04-25 Thomas Quinot <quinot@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference, cases Position, + First_Bit, and Last_Bit): Fix incorrect test in implementation of + RM 2005 13.5.2(3/2). + +2013-04-25 Claire Dross <dross@adacore.com> + + * a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads, a-cfhama.adb, + a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads + (Query_Element): Removed. + (Update_Element): Removed. + (Insert): The version with no New_Item specified is removed. + (Iterate): Removed. + (Write): Removed. + (Read): Removed. + Every check of fields Busy and Lock has been removed. + +2013-04-25 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb (Analyze_Pragma, case Contract_Cases): Remove + call to S14_Pragma (Find_Related_Subprogram): Require proper + placement in subprogram body (Find_Related_Subprogram): Detect + duplicates for all cases (Find_Related_Subprogram): Handle case + of spec nested inside body. + 2013-04-25 Arnaud Charlet <charlet@adacore.com> * par-prag.adb: Fix typo. diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb index c692cb66674..fc5c986ec2a 100644 --- a/gcc/ada/a-cfhama.adb +++ b/gcc/ada/a-cfhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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- -- @@ -159,8 +159,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Source length exceeds Target capacity"; end if; - -- Check busy bits - Clear (Target); Insert_Elements (Source); @@ -266,11 +264,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Position cursor of Delete has no element"; end if; - if Container.Busy > 0 then - raise Program_Error with - "Delete attempted to tamper with elements (map is busy)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); @@ -495,10 +488,6 @@ package body Ada.Containers.Formal_Hashed_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "Include attempted to tamper with cursors (map is locked)"; - end if; declare N : Node_Type renames Container.Nodes (Position.Node); @@ -516,54 +505,6 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - 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; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - - Local_Insert (Container, Key, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type; Position : out Cursor; Inserted : out Boolean) @@ -635,47 +576,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return Length (Container) = 0; end Is_Empty; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null - access procedure (Container : Map; Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - --------- -- Key -- --------- @@ -752,11 +652,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); if Source.Length = 0 then @@ -849,105 +744,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return False; end Overlap; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - 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"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - 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); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -965,11 +761,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "attempt to replace key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace attempted to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Node); begin @@ -993,11 +784,6 @@ package body Ada.Containers.Formal_Hashed_Maps is "Position cursor of Replace_Element has no element"; end if; - if Container.Lock > 0 then - raise Program_Error with - "Replace_Element attempted to tamper with cursors (map is locked)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); @@ -1085,52 +871,6 @@ package body Ada.Containers.Formal_Hashed_Maps is return True; end Strict_Equal; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - 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"; - end if; - - pragma Assert (Vet (Container, Position), - "bad cursor in Update_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - --------- -- Vet -- --------- @@ -1191,46 +931,4 @@ package body Ada.Containers.Formal_Hashed_Maps is end; end Vet; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads index c076d4072d5..fdbd7a0a8a4 100644 --- a/gcc/ada/a-cfhama.ads +++ b/gcc/ada/a-cfhama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -52,7 +52,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; -private with Ada.Streams; generic type Key_Type is private; @@ -87,14 +86,15 @@ package Ada.Containers.Formal_Hashed_Maps is function Is_Empty (Container : Map) return Boolean; - -- ??? what does clear do to active elements? procedure Clear (Container : in out Map); procedure Assign (Target : in out Map; Source : Map); - -- ??? - -- capacity=0 means use container.length as cap of tgt - -- modulos=0 means use default_modulous(container.length) + -- Copy returns a container stricty equal to Source + -- It must have the same cursors associated to each element + -- Therefore: + -- - capacity=0 means use container.capacity as cap of tgt + -- - the modulus cannot be changed. function Copy (Source : Map; Capacity : Count_Type := 0) return Map; @@ -108,18 +108,6 @@ package Ada.Containers.Formal_Hashed_Maps is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -132,12 +120,6 @@ package Ada.Containers.Formal_Hashed_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type); procedure Include @@ -186,11 +168,6 @@ package Ada.Containers.Formal_Hashed_Maps is Right : Map; CRight : Cursor) return Boolean; - procedure Iterate - (Container : Map; - Process : not null access - procedure (Container : Map; Position : Cursor)); - function Default_Modulus (Capacity : Count_Type) return Hash_Type; function Strict_Equal (Left, Right : Map) return Boolean; @@ -237,39 +214,11 @@ private new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; type Cursor is record Node : Count_Type; end record; - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); No_Element : constant Cursor := (Node => 0); diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index d5d73e2a1e8..539a0a88fe6 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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- -- @@ -295,11 +295,6 @@ package body Ada.Containers.Formal_Hashed_Sets is raise Constraint_Error with "Position cursor has no element"; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); @@ -333,11 +328,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - if Src_Length >= Target.Length then Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop @@ -572,9 +562,6 @@ package body Ada.Containers.Formal_Hashed_Sets is end; end Equivalent_Elements; - -- What does the following comment signify??? - -- NOT MODIFIED - --------------------- -- Equivalent_Keys -- --------------------- @@ -700,10 +687,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; Container.Nodes (Position.Node).Element := New_Item; end if; @@ -804,11 +787,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - Tgt_Node := HT_Ops.First (Target); while Tgt_Node /= 0 loop if Find (Source, TN (Tgt_Node).Element).Node /= 0 then @@ -930,48 +908,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return True; end Is_Subset; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Left -- ---------- @@ -1029,11 +965,6 @@ package body Ada.Containers.Formal_Hashed_Sets is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); if Source.Length = 0 then @@ -1117,103 +1048,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return False; end Overlap; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Query_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Query_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Container.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - 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); - - procedure Allocate is new Generic_Allocate (Read_Element); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1230,11 +1064,6 @@ package body Ada.Containers.Formal_Hashed_Sets is "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - Container.Nodes (Node).Element := New_Item; end Replace; @@ -1391,11 +1220,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; - Iterate (Source); end Symmetric_Difference; @@ -1475,10 +1299,6 @@ package body Ada.Containers.Formal_Hashed_Sets is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (set is busy)"; - end if; Iterate (Source); end Union; @@ -1557,47 +1377,6 @@ package body Ada.Containers.Formal_Hashed_Sets is end; end Vet; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; package body Generic_Keys is ----------------------- @@ -1752,90 +1531,6 @@ package body Ada.Containers.Formal_Hashed_Sets is Replace_Element (Container, Node, New_Item); end Replace; - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - Indx : Hash_Type; - N : Nodes_Type renames Container.Nodes; - - begin - if Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), - "bad cursor in Update_Element_Preserving_Key"); - - -- 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; - - begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Equivalent_Keys (K, Key (E)) then - pragma Assert (Hash (K) = Hash (E)); - return; - end if; - end; - - -- Key was modified, so remove this node from set - - if Container.Buckets (Indx) = Position.Node then - Container.Buckets (Indx) := N (Position.Node).Next; - - else - declare - Prev : Count_Type := Container.Buckets (Indx); - - begin - while N (Prev).Next /= Position.Node loop - Prev := N (Prev).Next; - - if Prev = 0 then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - N (Prev).Next := N (Position.Node).Next; - end; - end if; - - Container.Length := Container.Length - 1; - Free (Container, Position.Node); - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - end Generic_Keys; end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads index ad6c72fe151..a9278dcdbf0 100644 --- a/gcc/ada/a-cfhase.ads +++ b/gcc/ada/a-cfhase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -52,7 +52,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Hash_Tables; -private with Ada.Streams; generic type Element_Type is private; @@ -68,8 +67,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); + pragma Preelaborable_Initialization (Set); type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -108,11 +106,6 @@ package Ada.Containers.Formal_Hashed_Sets is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -187,11 +180,6 @@ package Ada.Containers.Formal_Hashed_Sets is (Left : Element_Type; Right : Set; CRight : Cursor) return Boolean; - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)); - function Default_Modulus (Capacity : Count_Type) return Hash_Type; generic @@ -222,12 +210,6 @@ package Ada.Containers.Formal_Hashed_Sets is function Contains (Container : Set; Key : Key_Type) return Boolean; - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - end Generic_Keys; function Strict_Equal (Left, Right : Set) return Boolean; @@ -262,38 +244,13 @@ private new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; - use Ada.Streams; type Cursor is record Node : Count_Type; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index 6b45ad60369..ac763918283 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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- -- @@ -558,11 +558,6 @@ package body Ada.Containers.Formal_Ordered_Maps is Insert (Container, Key, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Position.Node); begin @@ -635,56 +630,6 @@ package body Ada.Containers.Formal_Ordered_Maps is end if; end Insert; - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access 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; - end Initialize; - - X : Node_Access; - - -- Start of processing for New_Node - - begin - Allocate_Node (Container, X); - return X; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint (Container, Key, Position.Node, Inserted); - end Insert; - -------------- -- Is_Empty -- -------------- @@ -720,48 +665,6 @@ package body Ada.Containers.Formal_Ordered_Maps is return Left < Right.Key; end Is_Less_Key_Node; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : - not null access procedure (Container : Map; Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - --------- -- Key -- --------- @@ -881,11 +784,6 @@ package body Ada.Containers.Formal_Ordered_Maps is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); loop @@ -1014,93 +912,6 @@ package body Ada.Containers.Formal_Ordered_Maps is end; end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access 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"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Query_Element is bad"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1119,11 +930,6 @@ package body Ada.Containers.Formal_Ordered_Maps is raise Constraint_Error with "key not in map"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - declare N : Node_Type renames Container.Nodes (Node); begin @@ -1148,59 +954,12 @@ package body Ada.Containers.Formal_Ordered_Maps is "Position cursor of Replace_Element has no element"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (map is locked)"; - end if; - pragma Assert (Vet (Container, Position.Node), "Position cursor of Replace_Element is bad"); Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Container : Map; - Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Reverse_Iterate - - begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1305,93 +1064,4 @@ package body Ada.Containers.Formal_Ordered_Maps is return False; end Strict_Equal; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - 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"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Update_Element is bad"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - declare - N : Node_Type renames Container.Nodes (Position.Node); - K : Key_Type renames N.Key; - E : Element_Type renames N.Element; - - begin - Process (K, E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads index 145ff513d3d..c96fee02d51 100644 --- a/gcc/ada/a-cforma.ads +++ b/gcc/ada/a-cforma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -54,7 +54,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; generic type Key_Type is private; @@ -99,18 +98,6 @@ package Ada.Containers.Formal_Ordered_Maps is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - procedure Move (Target : in out Map; Source : in out Map); procedure Insert @@ -123,12 +110,6 @@ package Ada.Containers.Formal_Ordered_Maps is procedure Insert (Container : in out Map; Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; New_Item : Element_Type); procedure Include @@ -183,16 +164,6 @@ package Ada.Containers.Formal_Ordered_Maps is function Has_Element (Container : Map; Position : Cursor) return Boolean; - procedure Iterate - (Container : Map; - Process : - not null access procedure (Container : Map; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Map; - Process : not null access - procedure (Container : Map; Position : Cursor)); - function Strict_Equal (Left, Right : Map) return Boolean; -- Strict_Equal returns True if the containers are physically equal, i.e. -- they are structurally equal (function "=" returns True) and that they @@ -234,38 +205,12 @@ private type Map (Capacity : Count_Type) is new Tree_Types.Tree_Type (Capacity) with null record; - use Ada.Streams; - type Cursor is record Node : Node_Access; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; + Empty_Map : constant Map := (Capacity => 0, others => <>); No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - Empty_Map : constant Map := (Capacity => 0, others => <>); - end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 0707d74d0e8..22e92220b9d 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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- -- @@ -807,64 +807,6 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; end Replace; - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - 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"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Update_Element_Preserving_Key"); - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - - E : Element_Type renames N (Position.Node).Element; - K : constant Key_Type := Key (E); - - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (E); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - declare - X : constant Count_Type := Position.Node; - begin - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - end Generic_Keys; ----------------- @@ -892,11 +834,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Insert (Container, New_Item, Position, Inserted); if not Inserted then - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - declare N : Tree_Types.Nodes_Type renames Container.Nodes; begin @@ -1122,50 +1059,6 @@ package body Ada.Containers.Formal_Ordered_Sets is return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); end Is_Subset; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Container : Set; - Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - -- Local variables - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of prccessing for Iterate - - begin - B := B + 1; - - begin - Local_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Last -- ---------- @@ -1257,11 +1150,6 @@ package body Ada.Containers.Formal_Ordered_Sets is "Source length exceeds Target capacity"; end if; - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors of Source (list is busy)"; - end if; - Clear (Target); loop @@ -1347,85 +1235,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Position := Previous (Container, Position); end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : in out Set; - Position : Cursor; - 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; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Query_Element"); - - declare - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - B := B + 1; - L := L + 1; - - begin - Process (Container.Nodes (Position.Node).Element); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - ------------- -- Replace -- ------------- @@ -1439,11 +1248,6 @@ package body Ada.Containers.Formal_Ordered_Sets is "attempt to replace element not in set"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - Container.Nodes (Node).Element := New_Item; end Replace; @@ -1502,11 +1306,6 @@ package body Ada.Containers.Formal_Ordered_Sets is null; else - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - NN (Node).Element := Item; return; end if; @@ -1518,11 +1317,6 @@ package body Ada.Containers.Formal_Ordered_Sets is elsif Item < NN (Hint).Element then if Hint = Node then - if Tree.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (set is locked)"; - end if; - NN (Node).Element := Item; return; end if; @@ -1532,7 +1326,7 @@ package body Ada.Containers.Formal_Ordered_Sets is raise Program_Error with "attempt to replace existing element"; end if; - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); Local_Insert_With_Hint (Tree => Tree, @@ -1562,48 +1356,6 @@ package body Ada.Containers.Formal_Ordered_Sets is Replace_Element (Container, Position.Node, New_Item); end Replace_Element; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Container : Set; - Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Container, (Node => Node)); - end Process_Node; - - B : Natural renames Container'Unrestricted_Access.Busy; - - -- Start of processing for Reverse_Iterate - - begin - B := B + 1; - - begin - Local_Reverse_Iterate (Container); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1781,46 +1533,4 @@ package body Ada.Containers.Formal_Ordered_Sets is end return; end Union; - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Element); - - procedure Write_Elements is - new Tree_Operations.Generic_Write (Write_Element); - - ------------------- - -- Write_Element -- - ------------------- - - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Element; - - -- Start of processing for Write - - begin - Write_Elements (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads index 03203cdbd7b..77862a6df34 100644 --- a/gcc/ada/a-cforse.ads +++ b/gcc/ada/a-cforse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -53,7 +53,6 @@ -- See detailed specifications for these subprograms private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; generic type Element_Type is private; @@ -100,11 +99,6 @@ package Ada.Containers.Formal_Ordered_Sets is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - procedure Move (Target : in out Set; Source : in out Set); procedure Insert @@ -195,16 +189,6 @@ package Ada.Containers.Formal_Ordered_Sets is function Has_Element (Container : Set; Position : Cursor) return Boolean; - procedure Iterate - (Container : Set; - Process : - not null access procedure (Container : Set; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Set; - Process : not null access - procedure (Container : Set; Position : Cursor)); - generic type Key_Type (<>) is private; @@ -237,12 +221,6 @@ package Ada.Containers.Formal_Ordered_Sets is function Contains (Container : Set; Key : Key_Type) return Boolean; - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - end Generic_Keys; function Strict_Equal (Left, Right : Set) return Boolean; @@ -280,41 +258,13 @@ private new Tree_Types.Tree_Type (Capacity) with null record; use Red_Black_Trees; - use Ada.Streams; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; type Cursor is record Node : Count_Type; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - No_Element : constant Cursor := (Node => 0); - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - Empty_Set : constant Set := (Capacity => 0, others => <>); end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 548512d5536..69de29db5d4 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2013, 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- -- @@ -37,6 +37,11 @@ package body Ada.Containers.Formal_Vectors is (Container : Vector; Position : Count_Type) return Element_Type; + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + --------- -- "&" -- --------- @@ -256,7 +261,7 @@ package body Ada.Containers.Formal_Vectors is -- Capacity -- -------------- - function Capacity (Container : Vector) return Capacity_Subtype is + function Capacity (Container : Vector) return Count_Type is begin return Container.Elements'Length; end Capacity; @@ -267,11 +272,6 @@ package body Ada.Containers.Formal_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - Container.Last := No_Index; end Clear; @@ -293,10 +293,10 @@ package body Ada.Containers.Formal_Vectors is function Copy (Source : Vector; - Capacity : Capacity_Subtype := 0) return Vector + Capacity : Count_Type := 0) return Vector is LS : constant Count_Type := Length (Source); - C : Capacity_Subtype; + C : Count_Type; begin if Capacity = 0 then @@ -339,11 +339,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare I_As_Int : constant Int := Int (Index); Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); @@ -437,11 +432,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - Index := Int'Base (Container.Last) - Int'Base (Count); if Index < Index_Type'Pos (Index_Type'First) then @@ -607,7 +597,7 @@ package body Ada.Containers.Formal_Vectors is end if; declare - L : constant Capacity_Subtype := Length (Container); + L : constant Count_Type := Length (Container); begin for J in Count_Type range 1 .. L - 1 loop if Get_Element (Container, J + 1) < @@ -650,16 +640,6 @@ package body Ada.Containers.Formal_Vectors is -- I think we're missing this check in a-convec.adb... ??? - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - I := Length (Target); Target.Set_Length (I + Length (Source)); @@ -709,11 +689,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - Sort (Container.Elements (1 .. Length (Container))); end Sort; @@ -807,11 +782,6 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare EA : Elements_Array renames Container.Elements; @@ -1055,30 +1025,6 @@ package body Ada.Containers.Formal_Vectors is Position := Cursor'(True, Index); end Insert; - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - ------------------ -- Insert_Space -- ------------------ @@ -1138,11 +1084,6 @@ package body Ada.Containers.Formal_Vectors is -- Resolve issue of capacity vs. max index ??? end; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - declare EA : Elements_Array renames Container.Elements; @@ -1166,46 +1107,6 @@ package body Ada.Containers.Formal_Vectors is Container.Last := New_Last; end Insert_Space; - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Count = 0 then - if not Before.Valid - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (True, Before.Index); - end if; - - return; - end if; - - if not Before.Valid - or else Before.Index > Container.Last - then - if Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count => Count); - - Position := Cursor'(True, Index); - end Insert_Space; - -------------- -- Is_Empty -- -------------- @@ -1215,34 +1116,6 @@ package body Ada.Containers.Formal_Vectors is return Last_Index (Container) < Index_Type'First; end Is_Empty; - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : - not null access procedure (Container : Vector; Position : Cursor)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - - begin - B := B + 1; - - begin - for Indx in Index_Type'First .. Last_Index (Container) loop - Process (Container, Cursor'(True, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Iterate; - ---------- -- Last -- ---------- @@ -1282,13 +1155,13 @@ package body Ada.Containers.Formal_Vectors is -- Length -- ------------ - function Length (Container : Vector) return Capacity_Subtype is + function Length (Container : Vector) return Count_Type is L : constant Int := Int (Last_Index (Container)); F : constant Int := Int (Index_Type'First); N : constant Int'Base := L - F + 1; begin - return Capacity_Subtype (N); + return Count_Type (N); end Length; ---------- @@ -1328,16 +1201,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Target.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (Target is busy)"; - end if; - - if Source.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (Source is busy)"; - end if; - if N > Target.Capacity then raise Constraint_Error with -- correct exception here??? "length of Source is greater than capacity of Target"; @@ -1440,96 +1303,6 @@ package body Ada.Containers.Formal_Vectors is return No_Element; end Previous; - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - L : Natural renames V.Lock; - - begin - if Index > Last_Index (Container) then - raise Constraint_Error with "Index is out of range"; - end if; - - B := B + 1; - L := L + 1; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Count_Type := Count_Type (II); - - begin - Process (Get_Element (V, I)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Query_Element; - - procedure Query_Element - (Container : Vector; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if not Position.Valid then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Query_Element (Container, Position.Index, Process); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := No_Index; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length < 0 then - raise Program_Error with "stream appears to be corrupt"; - end if; - - if Length > Container.Capacity then - raise Storage_Error with "not enough capacity"; -- ??? - end if; - - for J in Count_Type range 1 .. Length loop - Last := Last + 1; - Element_Type'Read (Stream, Container.Elements (J)); - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - --------------------- -- Replace_Element -- --------------------- @@ -1544,11 +1317,6 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "Index is out of range"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); @@ -1572,11 +1340,6 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "Position cursor is out of range"; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); @@ -1591,11 +1354,11 @@ package body Ada.Containers.Formal_Vectors is procedure Reserve_Capacity (Container : in out Vector; - Capacity : Capacity_Subtype) + Capacity : Count_Type) is begin if Capacity > Container.Capacity then - raise Constraint_Error; -- ??? + raise Constraint_Error with "Capacity is out of range"; end if; end Reserve_Capacity; @@ -1609,11 +1372,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare I, J : Count_Type; E : Elements_Array renames Container.Elements; @@ -1699,34 +1457,6 @@ package body Ada.Containers.Formal_Vectors is return No_Index; end Reverse_Find_Index; - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Container : Vector; - Position : Cursor)) - is - V : Vector renames Container'Unrestricted_Access.all; - B : Natural renames V.Busy; - - begin - B := B + 1; - - begin - for Indx in reverse Index_Type'First .. Last_Index (Container) loop - Process (Container, Cursor'(True, Indx)); - end loop; - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Reverse_Iterate; - ----------- -- Right -- ----------- @@ -1757,18 +1487,13 @@ package body Ada.Containers.Formal_Vectors is procedure Set_Length (Container : in out Vector; - Length : Capacity_Subtype) + Length : Count_Type) is begin if Length = Formal_Vectors.Length (Container) then return; end if; - if Container.Busy > 0 then - raise Program_Error with - "attempt to tamper with elements (vector is busy)"; - end if; - if Length > Container.Capacity then raise Constraint_Error; -- ??? end if; @@ -1799,11 +1524,6 @@ package body Ada.Containers.Formal_Vectors is return; end if; - if Container.Lock > 0 then - raise Program_Error with - "attempt to tamper with cursors (vector is locked)"; - end if; - declare II : constant Int'Base := Int (I) - Int (No_Index); JJ : constant Int'Base := Int (J) - Int (No_Index); @@ -1865,32 +1585,9 @@ package body Ada.Containers.Formal_Vectors is -- To_Vector -- --------------- - function To_Vector (Length : Capacity_Subtype) return Vector is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return (Length, (others => <>), Last => Last, - others => <>); - end; - end To_Vector; - function To_Vector (New_Item : Element_Type; - Length : Capacity_Subtype) return Vector + Length : Count_Type) return Vector is begin if Length = 0 then @@ -1914,78 +1611,4 @@ package body Ada.Containers.Formal_Vectors is end; end To_Vector; - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - L : Natural renames Container.Lock; - - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - B := B + 1; - L := L + 1; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Count_Type := Count_Type (II); - - begin - Process (Container.Elements (I)); - exception - when others => - L := L - 1; - B := B - 1; - raise; - end; - - L := L - 1; - B := B - 1; - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if not Position.Valid then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - begin - Count_Type'Base'Write (Stream, Length (Container)); - - for J in 1 .. Length (Container) loop - Element_Type'Write (Stream, Container.Elements (J)); - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads index 24e2944fb7e..4d943837b82 100644 --- a/gcc/ada/a-cofove.ads +++ b/gcc/ada/a-cofove.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -55,7 +55,6 @@ -- iterate over containers. Left returns the part of the container already -- scanned and Right the part not scanned yet. -private with Ada.Streams; with Ada.Containers; use Ada.Containers; @@ -72,21 +71,9 @@ package Ada.Containers.Formal_Vectors is range Index_Type'First - 1 .. Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - -- ??? i don't think we can do this... - -- TODO: we need the ARG to either figure out how to declare this subtype, - -- or eliminate the requirement that it be present. - -- subtype Capacity_Subtype is Count_Type -- correct name??? - -- range 0 .. Count_Type'Max (0, - -- Index_Type'Pos (Index_Type'Last) - - -- Index_Type'Pos (Index_Type'First) + 1); - -- - -- so for now: - subtype Capacity_Subtype is Count_Type; - No_Index : constant Extended_Index := Extended_Index'First; - type Vector (Capacity : Capacity_Subtype) is tagged private; - -- pragma Preelaborable_Initialization (Vector); + type Vector (Capacity : Count_Type) is tagged private; type Cursor is private; pragma Preelaborable_Initialization (Cursor); @@ -97,11 +84,9 @@ package Ada.Containers.Formal_Vectors is function "=" (Left, Right : Vector) return Boolean; - function To_Vector (Length : Capacity_Subtype) return Vector; - function To_Vector (New_Item : Element_Type; - Length : Capacity_Subtype) return Vector; + Length : Count_Type) return Vector; function "&" (Left, Right : Vector) return Vector; @@ -111,17 +96,17 @@ package Ada.Containers.Formal_Vectors is function "&" (Left, Right : Element_Type) return Vector; - function Capacity (Container : Vector) return Capacity_Subtype; + function Capacity (Container : Vector) return Count_Type; procedure Reserve_Capacity (Container : in out Vector; - Capacity : Capacity_Subtype); + Capacity : Count_Type); - function Length (Container : Vector) return Capacity_Subtype; + function Length (Container : Vector) return Count_Type; procedure Set_Length (Container : in out Vector; - Length : Capacity_Subtype); + Length : Count_Type); function Is_Empty (Container : Vector) return Boolean; @@ -131,7 +116,7 @@ package Ada.Containers.Formal_Vectors is function Copy (Source : Vector; - Capacity : Capacity_Subtype := 0) return Vector; + Capacity : Count_Type := 0) return Vector; function To_Cursor (Container : Vector; @@ -157,26 +142,6 @@ package Ada.Containers.Formal_Vectors is Position : Cursor; New_Item : Element_Type); - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)); - - procedure Query_Element - (Container : Vector; - Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - procedure Move (Target : in out Vector; Source : in out Vector); procedure Insert @@ -214,17 +179,6 @@ package Ada.Containers.Formal_Vectors is Position : out Cursor; Count : Count_Type := 1); - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - procedure Prepend (Container : in out Vector; New_Item : Vector); @@ -243,17 +197,6 @@ package Ada.Containers.Formal_Vectors is New_Item : Element_Type; Count : Count_Type := 1); - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - procedure Delete (Container : in out Vector; Index : Extended_Index; @@ -324,16 +267,6 @@ package Ada.Containers.Formal_Vectors is function Has_Element (Container : Vector; Position : Cursor) return Boolean; - procedure Iterate - (Container : Vector; - Process : not null access - procedure (Container : Vector; Position : Cursor)); - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access - procedure (Container : Vector; Position : Cursor)); - generic with function "<" (Left, Right : Element_Type) return Boolean is <>; package Generic_Sorting is @@ -357,8 +290,6 @@ private pragma Inline (Element); pragma Inline (First_Element); pragma Inline (Last_Element); - pragma Inline (Query_Element); - pragma Inline (Update_Element); pragma Inline (Replace_Element); pragma Inline (Contains); pragma Inline (Next); @@ -367,44 +298,16 @@ private type Elements_Array is array (Count_Type range <>) of Element_Type; function "=" (L, R : Elements_Array) return Boolean is abstract; - type Vector (Capacity : Capacity_Subtype) is tagged record + type Vector (Capacity : Count_Type) is tagged record Elements : Elements_Array (1 .. Capacity); Last : Extended_Index := No_Index; - Busy : Natural := 0; - Lock : Natural := 0; end record; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector); - - for Vector'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector); - - for Vector'Read use Read; - type Cursor is record Valid : Boolean := True; Index : Index_Type := Index_Type'First; end record; - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - Empty_Vector : constant Vector := (Capacity => 0, others => <>); No_Element : constant Cursor := (Valid => False, Index => Index_Type'First); diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 5a5b7d1fc7b..570bfbc8a14 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2502,8 +2502,8 @@ package body Checks is -- Here for normal case of predicate active else - -- If the type has a static predicate and the expression is also - -- static, see if the expression satisfies the predicate. + -- If the type has a static predicate and the expression is known + -- at compile time, see if the expression satisfies the predicate. Check_Expression_Against_Static_Predicate (N, Typ); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 93f9b819de7..9e48afe8882 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2741,20 +2741,20 @@ package body Exp_Attr is CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(3/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, then + -- we return the original value as given in the component clause + -- (RM 2005 13.5.2(3/2)). if Present (Component_Clause (CE)) and then Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (First_Bit (Component_Clause (CE))))); Analyze_And_Resolve (N, Typ); - -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), -- rewrite with normalized value if we know it statically. elsif Known_Static_Component_Bit_Offset (CE) then @@ -3321,20 +3321,20 @@ package body Exp_Attr is CE : constant Entity_Id := Entity (Selector_Name (Pref)); begin - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(4/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, then + -- we return the original value as given in the component clause + -- (RM 2005 13.5.2(3/2)). if Present (Component_Clause (CE)) and then Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (Last_Bit (Component_Clause (CE))))); Analyze_And_Resolve (N, Typ); - -- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order), + -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order), -- rewrite with normalized value if we know it statically. elsif Known_Static_Component_Bit_Offset (CE) @@ -4243,18 +4243,18 @@ package body Exp_Attr is begin if Present (Component_Clause (CE)) then - -- In Ada 2005 (or later) if we have the standard nondefault - -- bit order, then we return the original value as given in - -- the component clause (RM 2005 13.5.2(2/2)). + -- In Ada 2005 (or later) if we have the non-default bit order, + -- then we return the original value as given in the component + -- clause (RM 2005 13.5.2(2/2)). if Ada_Version >= Ada_2005 - and then not Reverse_Bit_Order (Scope (CE)) + and then Reverse_Bit_Order (Scope (CE)) then Rewrite (N, Make_Integer_Literal (Loc, Intval => Expr_Value (Position (Component_Clause (CE))))); - -- Otherwise (Ada 83 or 95, or reverse bit order specified in + -- Otherwise (Ada 83 or 95, or default bit order specified in -- later Ada version), return the normalized value. else diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 08177737587..a3b2c4e3a3e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3277,8 +3277,8 @@ package body Sem_Ch3 is or else Is_Partially_Initialized_Type (T, Include_Implicit => False)) then - -- If the type has a static predicate and the expression is also - -- static, see if the expression satisfies the predicate. + -- If the type has a static predicate and the expression is known at + -- compile time, see if the expression satisfies the predicate. if Present (E) then Check_Expression_Against_Static_Predicate (E, T); @@ -3297,8 +3297,7 @@ package body Sem_Ch3 is if Is_String_Type (T) and then not Constant_Present (N) then Check_SPARK_Restriction - ("declaration of object of unconstrained type not allowed", - N); + ("declaration of object of unconstrained type not allowed", N); end if; -- Nothing to do in deferred constant case diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7f5b5512bf1..e148d05bbf2 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -202,7 +202,11 @@ package body Sem_Prag is Check_Duplicates : Boolean := False) return Node_Id; -- Find the declaration of the related subprogram subject to pragma Prag. -- If flag Check_Duplicates is set, the routine emits errors concerning - -- duplicate pragmas. + -- duplicate pragmas. If a related subprogram is found, then either the + -- corresponding N_Subprogram_Declaration node is returned, or, if the + -- pragma applies to a subprogram body, then the N_Subprogram_Body node + -- is returned. Note that in the latter case, no check is made to ensure + -- that there is no separate declaration of the subprogram. function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; -- If Def_Id refers to a renamed subprogram, then the base subprogram (the @@ -10043,7 +10047,6 @@ package body Sem_Prag is begin GNAT_Pragma; - S14_Pragma; Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Contract_Cases must @@ -18113,63 +18116,83 @@ package body Sem_Prag is is Context : constant Node_Id := Parent (Prag); Nam : constant Name_Id := Pragma_Name (Prag); - Decl : Node_Id; + Elmt : Node_Id; Subp_Decl : Node_Id; begin - -- The pragma is a byproduct of an aspect + pragma Assert (Nkind (Prag) = N_Pragma); + + -- If the pragma comes from an aspect, then what we want is the + -- declaration to which the aspect is attached, i.e. its parent. if Present (Corresponding_Aspect (Prag)) then - Subp_Decl := Parent (Corresponding_Aspect (Prag)); + return Parent (Corresponding_Aspect (Prag)); + end if; - -- The pragma is associated with a library-level subprogram + -- Otherwise the pragma must be a list element, and the first thing to + -- do is to position past any previous pragmas or generated code. What + -- we are doing here is looking for the preceding declaration. This is + -- also where we will check for a duplicate pragma. - elsif Nkind (Context) = N_Compilation_Unit_Aux then - Subp_Decl := Unit (Parent (Context)); + pragma Assert (Is_List_Member (Prag)); - -- The pragma appears inside the declarative part of a subprogram body + Elmt := Prag; + loop + Elmt := Prev (Elmt); + exit when No (Elmt); - elsif Nkind (Context) = N_Subprogram_Body then - Subp_Decl := Context; + -- Typically want we will want is the declaration original node. But + -- for the generic subprogram case, don't go to to the original node, + -- which is the unanalyzed tree: we need to attach the pre- and post- + -- conditions to the analyzed version at this point. They propagate + -- to the original tree when analyzing the corresponding body. - -- The pragma appears someplace after its related subprogram. Inspect - -- all previous declarations for a suitable candidate. + if Nkind (Elmt) not in N_Generic_Declaration then + Subp_Decl := Original_Node (Elmt); + else + Subp_Decl := Elmt; + end if; - else - Decl := Prag; - Subp_Decl := Empty; - while Present (Prev (Decl)) loop - Decl := Prev (Decl); + -- Skip prior pragmas - if Nkind (Decl) in N_Generic_Declaration then - Subp_Decl := Decl; - else - Subp_Decl := Original_Node (Decl); + if Nkind (Subp_Decl) = N_Pragma then + if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then + Error_Msg_Name_1 := Nam; + Error_Msg_Sloc := Sloc (Subp_Decl); + Error_Msg_N ("pragma % duplicates pragma declared #", Prag); end if; - -- Skip prior pragmas + -- Skip internally generated code - if Nkind (Subp_Decl) = N_Pragma then - if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then - Error_Msg_Name_1 := Nam; - Error_Msg_Sloc := Sloc (Subp_Decl); - Error_Msg_N ("pragma % duplicates pragma declared #", Prag); - end if; + elsif not Comes_From_Source (Subp_Decl) then + null; - -- Skip internally generated code + -- Otherwise we have a declaration to return - elsif not Comes_From_Source (Subp_Decl) then - null; + else + return Subp_Decl; + end if; + end loop; - -- The nearest preceding declaration is the related subprogram + -- We fell through, which means there was no declaration preceding the + -- pragma (either it was the first element of the list, or we only had + -- other pragmas and generated code before it). - else - exit; - end if; - end loop; - end if; + -- The pragma is associated with a library-level subprogram + + if Nkind (Context) = N_Compilation_Unit_Aux then + return Unit (Parent (Context)); - return Subp_Decl; + -- The pragma appears inside the declarative part of a subprogram body + + elsif Nkind (Context) = N_Subprogram_Body then + return Context; + + -- Otherwise no subprogram found, return original pragma + + else + return Prag; + end if; end Find_Related_Subprogram; ------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index bc1f3fb8fd7..c914703f894 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1301,11 +1301,11 @@ package body Sem_Util is Typ : Entity_Id) is begin - -- When both the predicate and the expression are static, evaluate the - -- check at compile time. A type becomes non-static when it has aspect - -- Dynamic_Predicate. + -- When the predicate is static and the value of the expression is known + -- at compile time, evaluate the predicate check. A type is non-static + -- when it has aspect Dynamic_Predicate. - if Is_OK_Static_Expression (Expr) + if Compile_Time_Known_Value (Expr) and then Has_Predicates (Typ) and then Present (Static_Predicate (Typ)) and then not Has_Dynamic_Predicate_Aspect (Typ) diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b5d1ed355c4..7ea5657aa2b 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -195,9 +195,9 @@ package Sem_Util is (Expr : Node_Id; Typ : Entity_Id); -- Determine whether an arbitrary expression satisfies the static predicate - -- of a type. The routine does nothing if Expr is non-static or Typ lacks a - -- static predicate, otherwise it may emit a warning if the expression is - -- prohibited by the predicate. + -- of a type. The routine does nothing if Expr is not known at compile time + -- or Typ lacks a static predicate, otherwise it may emit a warning if the + -- expression is prohibited by the predicate. procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); -- Verify that the full declaration of type T has been seen. If not, place |