diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 56 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.adb | 169 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.ads | 75 | ||||
| -rw-r--r-- | gcc/ada/a-cimutr.adb | 159 | ||||
| -rw-r--r-- | gcc/ada/a-cimutr.ads | 68 | ||||
| -rw-r--r-- | gcc/ada/a-comutr.adb | 159 | ||||
| -rw-r--r-- | gcc/ada/a-comutr.ads | 67 | ||||
| -rw-r--r-- | gcc/ada/exp_alfa.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_alfa.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 126 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_dist.adb | 202 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 3 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 5 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/s-osinte-darwin.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 33 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 4 |
24 files changed, 968 insertions, 241 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f57c46d..86bbd12 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,59 @@ +2011-09-19 Steve Baird <baird@adacore.com> + + * snames.ads-tmpl: Move declaration of Name_Annotate into range of + configuration pragma names so that Is_Configuration_Pragma_Name + will return True for Name_Annotate. Make corresponding change in + Pragma_Id enumeration type. This is needed to allow an Annotate + pragma to occur in a configuration pragma file (typically, + a gnat.adc file). + * gnat_ugn.texi: Add Annotate to the list of configuration pragmas. + * gnat_rm.texi: Note that pragma Annotate may be used as a + configuration pragma. + +2011-09-19 Ed Schonberg <schonberg@adacore.com> + + * a-cbmutr.adb, a-cbmutr.ads, a-cimutr.adb, a-cimutr.ads, + a-comutr.adb, a-comutr.ads: Add iterator machinery for multiway trees. + +2011-09-19 Yannick Moy <moy@adacore.com> + + * exp_alfa.adb, exp_alfa.ads (Expand_Alfa_N_In): New function + for expansion of set membership. + (Expand_Alfa): Call expansion for N_In and N_Not_In nodes. + * exp_ch4.adb, exp_ch4.ads (Expand_Set_Membership): Make procedure + visible for use in Alfa expansion. + * sem_ch5.adb (Analyze_Iterator_Specification): Introduce loop + variable in Alfa mode. + +2011-09-19 Thomas Quinot <quinot@adacore.com> + + * s-osinte-darwin.ads: Change SIGADAABRT on Darwin to SIGABRT. + +2011-09-19 Thomas Quinot <quinot@adacore.com> + + * exp_ch9.adb: Minor reformatting. + +2011-09-19 Hristian Kirtchev <kirtchev@adacore.com> + + * freeze.adb (Build_Renamed_Body): Generic subprograms + instantiations cannot be poperly inlined by the compiler, do + not set the Body_To_Inline attribute in such cases. + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Inherit all + inlining-related flags from the generic subprogram declaration. + +2011-09-19 Thomas Quinot <quinot@adacore.com> + + * exp_dist.adb, rtsfind.ads, sem_util.adb, sem_util.ads + (Build_Stub_Type): Remove, instead copy components from + System.Partition_Interface.RACW_Stub_Type. + (RPC_Receiver_Decl): Remainder of code from old Build_Stub_Type routine. + (Copy_Component_List): New subprogram. + +2011-09-19 Yannick Moy <moy@adacore.com> + + * lib-xref.adb (Generate_Reference): Ignore references to + constants in Standard. + 2011-09-19 Robert Dewar <dewar@adacore.com> * err_vars.ads, errout.ads: Minor reformatting. diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index e206e98..32ab082 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -28,9 +28,22 @@ ------------------------------------------------------------------------------ with System; use type System.Address; - package body Ada.Containers.Bounded_Multiway_Trees is + No_Node : constant Count_Type'Base := -1; + + type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Position : Cursor; + From_Root : Boolean; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -381,7 +394,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is First => First, Last => Last, Parent => Parent.Node, - Before => -1); -- means "insert at end of list" + Before => No_Node); -- means "insert at end of list" Container.Count := Container.Count + Count; end Append_Child; @@ -1223,6 +1236,11 @@ package body Ada.Containers.Bounded_Multiway_Trees is return Cursor'(Container'Unrestricted_Access, Node); end Find; + function First (Object : Iterator) return Cursor is + begin + return Object.Position; + end First; + ----------------- -- First_Child -- ----------------- @@ -1367,7 +1385,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is is begin Container.Nodes (Index) := - (Parent => -1, + (Parent => No_Node, Prev => 0, Next => 0, Children => (others => 0)); @@ -1715,6 +1733,23 @@ package body Ada.Containers.Bounded_Multiway_Trees is raise; end Iterate; + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + Root_Cursor : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin + return + Iterator'(Container'Unrestricted_Access, + First_Child (Root_Cursor), From_Root => True); + end Iterate; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class is + begin + return Iterator'(Position.Container, Position, From_Root => False); + end Iterate_Subtree; + ---------------------- -- Iterate_Children -- ---------------------- @@ -1888,6 +1923,74 @@ package body Ada.Containers.Bounded_Multiway_Trees is Source.Clear; end Move; + ---------- + -- Next -- + ---------- + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + T : Tree renames Position.Container.all; + NN : Tree_Node_Array renames T.Nodes; + N : Tree_Node_Type renames NN (Position.Node); + + begin + if Is_Leaf (Position) then + + -- If sibling is present, return it. + + if N.Next /= 0 then + return (Object.Container, N.Next); + + -- If this is the last sibling, go to sibling of first ancestor that + -- has a sibling, or terminate. + + else + declare + Pos : Count_Type := N.Parent; + Par : Tree_Node_Type := NN (Pos); + + begin + while Par.Next = 0 loop + Pos := Par.Parent; + + -- If we are back at the root the iteration is complete. + + if Pos = No_Node then + return No_Element; + + -- If this is a subtree iterator and we are back at the + -- starting node, iteration is complete. + + elsif Pos = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + + else + Par := NN (Pos); + end if; + end loop; + + if Pos = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + end if; + + return (Object.Container, Par.Next); + end; + end if; + + else + + -- If an internal node, return its first child. + + return (Object.Container, N.Children.First); + end if; + end Next; + ------------------ -- Next_Sibling -- ------------------ @@ -2224,6 +2327,50 @@ package body Ada.Containers.Bounded_Multiway_Trees is raise Program_Error with "attempt to read tree cursor from stream"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + pragma Unreferenced (Container); + + return + (Element => + Position.Container.Elements (Position.Node)'Unchecked_Access); + end Constant_Reference; + + function Reference + (Container : aliased Tree; + Position : Cursor) return Reference_Type + is + begin + pragma Unreferenced (Container); + + return + (Element => + Position.Container.Elements (Position.Node)'Unchecked_Access); + end Reference; + -------------------- -- Remove_Subtree -- -------------------- @@ -3073,4 +3220,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is raise Program_Error with "attempt to write tree cursor to stream"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads index 818cde2..f20af04 100644 --- a/gcc/ada/a-cbmutr.ads +++ b/gcc/ada/a-cbmutr.ads @@ -31,6 +31,7 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Iterator_Interfaces; private with Ada.Streams; generic @@ -42,7 +43,11 @@ package Ada.Containers.Bounded_Multiway_Trees is pragma Pure; pragma Remote_Types; - type Tree (Capacity : Count_Type) is tagged private; + type Tree (Capacity : Count_Type) is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; pragma Preelaborable_Initialization (Tree); type Cursor is private; @@ -51,6 +56,10 @@ package Ada.Containers.Bounded_Multiway_Trees is Empty_Tree : constant Tree; No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); function Equal_Subtree (Left_Position : Cursor; @@ -90,6 +99,14 @@ package Ada.Containers.Bounded_Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree; Capacity : Count_Type := 0) return Tree; @@ -148,8 +165,6 @@ package Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - procedure Iterate (Container : Tree; Process : not null access procedure (Position : Cursor)); @@ -158,6 +173,12 @@ package Ada.Containers.Bounded_Multiway_Trees is (Position : Cursor; Process : not null access procedure (Position : Cursor)); + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + function Child_Count (Parent : Cursor) return Count_Type; function Child_Depth (Parent, Child : Cursor) return Count_Type; @@ -273,6 +294,7 @@ package Ada.Containers.Bounded_Multiway_Trees is Process : not null access procedure (Position : Cursor)); private + use Ada.Streams; type Children_Type is record First : Count_Type'Base; @@ -287,7 +309,7 @@ private end record; type Tree_Node_Array is array (Count_Type range <>) of Tree_Node_Type; - type Element_Array is array (Count_Type range <>) of Element_Type; + type Element_Array is array (Count_Type range <>) of aliased Element_Type; type Tree (Capacity : Count_Type) is tagged record Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); @@ -298,8 +320,6 @@ private Count : Count_Type := 0; end record; - use Ada.Streams; - procedure Write (Stream : not null access Root_Stream_Type'Class; Container : Tree); @@ -320,19 +340,52 @@ private Node : Count_Type'Base := -1; end record; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + for Cursor'Read use Read; + procedure Write (Stream : not null access Root_Stream_Type'Class; Position : Cursor); - for Cursor'Write use Write; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + for Constant_Reference_Type'Write use Write; + procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + for Constant_Reference_Type'Read use Read; - for Cursor'Read use Read; + type Reference_Type + (Element : not null access Element_Type) is null record; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + for Reference_Type'Read use Read; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) + return Constant_Reference_Type; + + function Reference + (Container : aliased Tree; + Position : Cursor) + return Reference_Type; - Empty_Tree : constant Tree := Tree'(Capacity => 0, others => <>); + Empty_Tree : constant Tree := (Capacity => 0, others => <>); No_Element : constant Cursor := Cursor'(others => <>); diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 90fedae..96c1fe2 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -32,6 +32,18 @@ with System; use type System.Address; package body Ada.Containers.Indefinite_Multiway_Trees is + type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Position : Cursor; + From_Root : Boolean; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -915,6 +927,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is return Cursor'(Container'Unrestricted_Access, N); end Find; + ----------- + -- First -- + ----------- + + function First (Object : Iterator) return Cursor is + begin + return Object.Position; + end First; + ----------------- -- First_Child -- ----------------- @@ -1280,6 +1301,23 @@ package body Ada.Containers.Indefinite_Multiway_Trees is raise; end Iterate; + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + Root_Cursor : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin + return + Iterator'(Container'Unrestricted_Access, + First_Child (Root_Cursor), From_Root => True); + end Iterate; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class is + begin + return Iterator'(Position.Container, Position, From_Root => False); + end Iterate_Subtree; + ---------------------- -- Iterate_Children -- ---------------------- @@ -1446,6 +1484,71 @@ package body Ada.Containers.Indefinite_Multiway_Trees is Source.Count := 0; end Move; + ---------- + -- Next -- + ---------- + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + T : Tree renames Position.Container.all; + N : constant Tree_Node_Access := Position.Node; + + begin + if Is_Leaf (Position) then + + -- If sibling is present, return it. + + if N.Next /= null then + return (Object.Container, N.Next); + + -- If this is the last sibling, go to sibling of first ancestor that + -- has a sibling, or terminate. + + else + declare + Par : Tree_Node_Access := N.Parent; + + begin + while Par.Next = null loop + + -- If we are back at the root the iteration is complete. + + if Par = Root_Node (T) then + return No_Element; + + -- If this is a subtree iterator and we are back at the + -- starting node, iteration is complete. + + elsif Par = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + + else + Par := Par.Parent; + end if; + end loop; + + if Par = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + end if; + + return (Object.Container, Par.Next); + end; + end if; + + else + + -- If an internal node, return its first child. + + return (Object.Container, N.Children.First); + end if; + end Next; + ------------------ -- Next_Sibling -- ------------------ @@ -1746,6 +1849,46 @@ package body Ada.Containers.Indefinite_Multiway_Trees is raise Program_Error with "attempt to read tree cursor from stream"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + pragma Unreferenced (Container); + + return (Element => Position.Node.Element.all'Unchecked_Access); + end Constant_Reference; + + function Reference + (Container : aliased Tree; + Position : Cursor) return Reference_Type + is + begin + pragma Unreferenced (Container); + + return (Element => Position.Node.Element.all'Unchecked_Access); + end Reference; + -------------------- -- Remove_Subtree -- -------------------- @@ -2414,4 +2557,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is raise Program_Error with "attempt to write tree cursor to stream"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads index 9f3b5d7..c47f986 100644 --- a/gcc/ada/a-cimutr.ads +++ b/gcc/ada/a-cimutr.ads @@ -31,6 +31,7 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Iterator_Interfaces; private with Ada.Finalization; private with Ada.Streams; @@ -43,7 +44,12 @@ package Ada.Containers.Indefinite_Multiway_Trees is pragma Preelaborate; pragma Remote_Types; - type Tree is tagged private; + type Tree is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Tree); type Cursor is private; @@ -52,6 +58,10 @@ package Ada.Containers.Indefinite_Multiway_Trees is Empty_Tree : constant Tree; No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); function Equal_Subtree (Left_Position : Cursor; @@ -91,6 +101,14 @@ package Ada.Containers.Indefinite_Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree) return Tree; @@ -149,8 +167,6 @@ package Ada.Containers.Indefinite_Multiway_Trees is (Container : Tree; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - procedure Iterate (Container : Tree; Process : not null access procedure (Position : Cursor)); @@ -159,6 +175,12 @@ package Ada.Containers.Indefinite_Multiway_Trees is (Position : Cursor; Process : not null access procedure (Position : Cursor)); + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + function Child_Count (Parent : Cursor) return Count_Type; function Child_Depth (Parent, Child : Cursor) return Count_Type; @@ -343,6 +365,46 @@ private for Cursor'Read use Read; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is null record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) + return Constant_Reference_Type; + + function Reference + (Container : aliased Tree; + Position : Cursor) + return Reference_Type; + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index c4ad64e..17b70d4d 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -33,6 +33,18 @@ with System; use type System.Address; package body Ada.Containers.Multiway_Trees is + type Iterator is new Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Position : Cursor; + From_Root : Boolean; + end record; + + overriding function First (Object : Iterator) return Cursor; + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + ----------------------- -- Local Subprograms -- ----------------------- @@ -891,6 +903,15 @@ package body Ada.Containers.Multiway_Trees is return Cursor'(Container'Unrestricted_Access, N); end Find; + ----------- + -- First -- + ----------- + + function First (Object : Iterator) return Cursor is + begin + return Object.Position; + end First; + ----------------- -- First_Child -- ----------------- @@ -1323,6 +1344,23 @@ package body Ada.Containers.Multiway_Trees is raise; end Iterate; + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + Root_Cursor : constant Cursor := + (Container'Unrestricted_Access, Root_Node (Container)); + begin + return + Iterator'(Container'Unrestricted_Access, + First_Child (Root_Cursor), From_Root => True); + end Iterate; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class is + begin + return Iterator'(Position.Container, Position, From_Root => False); + end Iterate_Subtree; + ---------------------- -- Iterate_Children -- ---------------------- @@ -1490,6 +1528,71 @@ package body Ada.Containers.Multiway_Trees is Source.Count := 0; end Move; + ---------- + -- Next -- + ---------- + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + T : Tree renames Position.Container.all; + N : constant Tree_Node_Access := Position.Node; + + begin + if Is_Leaf (Position) then + + -- If sibling is present, return it. + + if N.Next /= null then + return (Object.Container, N.Next); + + -- If this is the last sibling, go to sibling of first ancestor that + -- has a sibling, or terminate. + + else + declare + Par : Tree_Node_Access := N.Parent; + + begin + while Par.Next = null loop + + -- If we are back at the root the iteration is complete. + + if Par = Root_Node (T) then + return No_Element; + + -- If this is a subtree iterator and we are back at the + -- starting node, iteration is complete. + + elsif Par = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + + else + Par := Par.Parent; + end if; + end loop; + + if Par = Object.Position.Node + and then not Object.From_Root + then + return No_Element; + end if; + + return (Object.Container, Par.Next); + end; + end if; + + else + + -- If an internal node, return its first child. + + return (Object.Container, N.Children.First); + end if; + end Next; + ------------------ -- Next_Sibling -- ------------------ @@ -1784,6 +1887,46 @@ package body Ada.Containers.Multiway_Trees is raise Program_Error with "attempt to read tree cursor from stream"; end Read; + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + pragma Unreferenced (Container); + + return (Element => Position.Node.Element'Unrestricted_Access); + end Constant_Reference; + + function Reference + (Container : aliased Tree; + Position : Cursor) return Reference_Type + is + begin + pragma Unreferenced (Container); + + return (Element => Position.Node.Element'Unrestricted_Access); + end Reference; + -------------------- -- Remove_Subtree -- -------------------- @@ -2460,4 +2603,20 @@ package body Ada.Containers.Multiway_Trees is raise Program_Error with "attempt to write tree cursor to stream"; end Write; + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index d2291df..00a78e3 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -31,6 +31,7 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ +with Ada.Iterator_Interfaces; private with Ada.Finalization; private with Ada.Streams; @@ -43,7 +44,11 @@ package Ada.Containers.Multiway_Trees is pragma Preelaborate; pragma Remote_Types; - type Tree is tagged private; + type Tree is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; pragma Preelaborable_Initialization (Tree); type Cursor is private; @@ -52,6 +57,10 @@ package Ada.Containers.Multiway_Trees is Empty_Tree : constant Tree; No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); function Equal_Subtree (Left_Position : Cursor; @@ -91,6 +100,14 @@ package Ada.Containers.Multiway_Trees is Position : Cursor; Process : not null access procedure (Element : in out Element_Type)); + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + procedure Assign (Target : in out Tree; Source : Tree); function Copy (Source : Tree) return Tree; @@ -149,8 +166,6 @@ package Ada.Containers.Multiway_Trees is (Container : Tree; Item : Element_Type) return Boolean; - function Has_Element (Position : Cursor) return Boolean; - procedure Iterate (Container : Tree; Process : not null access procedure (Position : Cursor)); @@ -159,6 +174,12 @@ package Ada.Containers.Multiway_Trees is (Position : Cursor; Process : not null access procedure (Position : Cursor)); + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + function Child_Count (Parent : Cursor) return Count_Type; function Child_Depth (Parent, Child : Cursor) return Count_Type; @@ -389,6 +410,46 @@ private for Cursor'Read use Read; + type Constant_Reference_Type + (Element : not null access constant Element_Type) is null record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is null record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) + return Constant_Reference_Type; + + function Reference + (Container : aliased Tree; + Position : Cursor) + return Reference_Type; + Empty_Tree : constant Tree := (Controlled with others => <>); No_Element : constant Cursor := (others => <>); diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb index 04c8484..988d16f 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_alfa.adb @@ -26,8 +26,10 @@ with Atree; use Atree; with Einfo; use Einfo; with Exp_Attr; use Exp_Attr; +with Exp_Ch4; use Exp_Ch4; with Exp_Ch6; use Exp_Ch6; with Exp_Dbug; use Exp_Dbug; +with Nlists; use Nlists; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; @@ -51,6 +53,9 @@ package body Exp_Alfa is procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id); -- Expand attributes 'Old and 'Result only + procedure Expand_Alfa_N_In (N : Node_Id); + -- Expand set membership into individual ones + procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); -- Insert conversion on function return if necessary @@ -81,6 +86,12 @@ package body Exp_Alfa is when N_Attribute_Reference => Expand_Alfa_N_Attribute_Reference (N); + when N_In => + Expand_Alfa_N_In (N); + + when N_Not_In => + Expand_N_Not_In (N); + when others => null; end case; @@ -167,6 +178,18 @@ package body Exp_Alfa is end case; end Expand_Alfa_N_Attribute_Reference; + ---------------------- + -- Expand_Alfa_N_In -- + ---------------------- + + procedure Expand_Alfa_N_In (N : Node_Id) is + begin + if Present (Alternatives (N)) then + Expand_Set_Membership (N); + return; + end if; + end Expand_Alfa_N_In; + ------------------------------------------- -- Expand_Alfa_N_Simple_Return_Statement -- ------------------------------------------- diff --git a/gcc/ada/exp_alfa.ads b/gcc/ada/exp_alfa.ads index a5c0786..dbb8cb2 100644 --- a/gcc/ada/exp_alfa.ads +++ b/gcc/ada/exp_alfa.ads @@ -37,7 +37,7 @@ -- conversions, expand actuals in calls to introduce temporaries) -- 2. Facilitate treatment for the formal verification back-end (fully --- qualify names) +-- qualify names, set membership) -- 3. Avoid the introduction of low-level code that is difficult to analyze -- formally, as typically done in the full expansion for high-level diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index aef54a6..c099933 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4630,68 +4630,6 @@ package body Exp_Ch4 is Ltyp : Entity_Id; Rtyp : Entity_Id; - procedure Expand_Set_Membership; - -- For each choice we create a simple equality or membership test. - -- The whole membership is rewritten connecting these with OR ELSE. - - --------------------------- - -- Expand_Set_Membership -- - --------------------------- - - procedure Expand_Set_Membership is - Alt : Node_Id; - Res : Node_Id; - - function Make_Cond (Alt : Node_Id) return Node_Id; - -- If the alternative is a subtype mark, create a simple membership - -- test. Otherwise create an equality test for it. - - --------------- - -- Make_Cond -- - --------------- - - function Make_Cond (Alt : Node_Id) return Node_Id is - Cond : Node_Id; - L : constant Node_Id := New_Copy (Lop); - R : constant Node_Id := Relocate_Node (Alt); - - begin - if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) - or else Nkind (Alt) = N_Range - then - Cond := - Make_In (Sloc (Alt), - Left_Opnd => L, - Right_Opnd => R); - else - Cond := - Make_Op_Eq (Sloc (Alt), - Left_Opnd => L, - Right_Opnd => R); - end if; - - return Cond; - end Make_Cond; - - -- Start of processing for Expand_Set_Membership - - begin - Alt := Last (Alternatives (N)); - Res := Make_Cond (Alt); - - Prev (Alt); - while Present (Alt) loop - Res := - Make_Or_Else (Sloc (Alt), - Left_Opnd => Make_Cond (Alt), - Right_Opnd => Res); - Prev (Alt); - end loop; - - Rewrite (N, Res); - Analyze_And_Resolve (N, Standard_Boolean); - end Expand_Set_Membership; - procedure Substitute_Valid_Check; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. @@ -4721,8 +4659,7 @@ package body Exp_Ch4 is -- If set membership case, expand with separate procedure if Present (Alternatives (N)) then - Remove_Side_Effects (Lop); - Expand_Set_Membership; + Expand_Set_Membership (N); return; end if; @@ -9717,6 +9654,67 @@ package body Exp_Ch4 is return Result; end Expand_Record_Equality; + --------------------------- + -- Expand_Set_Membership -- + --------------------------- + + procedure Expand_Set_Membership (N : Node_Id) is + Lop : constant Node_Id := Left_Opnd (N); + Alt : Node_Id; + Res : Node_Id; + + function Make_Cond (Alt : Node_Id) return Node_Id; + -- If the alternative is a subtype mark, create a simple membership + -- test. Otherwise create an equality test for it. + + --------------- + -- Make_Cond -- + --------------- + + function Make_Cond (Alt : Node_Id) return Node_Id is + Cond : Node_Id; + L : constant Node_Id := New_Copy (Lop); + R : constant Node_Id := Relocate_Node (Alt); + + begin + if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt))) + or else Nkind (Alt) = N_Range + then + Cond := + Make_In (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + else + Cond := + Make_Op_Eq (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + end if; + + return Cond; + end Make_Cond; + + -- Start of processing for Expand_Set_Membership + + begin + Remove_Side_Effects (Lop); + + Alt := Last (Alternatives (N)); + Res := Make_Cond (Alt); + + Prev (Alt); + while Present (Alt) loop + Res := + Make_Or_Else (Sloc (Alt), + Left_Opnd => Make_Cond (Alt), + Right_Opnd => Res); + Prev (Alt); + end loop; + + Rewrite (N, Res); + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Set_Membership; + ----------------------------------- -- Expand_Short_Circuit_Operator -- ----------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 17323f2..2e9c68b 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -91,6 +91,11 @@ package Exp_Ch4 is -- to insert those bodies at the right place. Nod provides the Sloc -- value for generated code. + procedure Expand_Set_Membership (N : Node_Id); + -- For each choice of a set membership, we create a simple equality or + -- membership test. The whole membership is rewritten connecting these + -- with OR ELSE. + function Integer_Promotion_Possible (N : Node_Id) return Boolean; -- Returns true if the node is a type conversion whose operand is an -- arithmetic operation on signed integers, and the base type of the diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index bbdb56b..5b9d4f8 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5219,7 +5219,7 @@ package body Exp_Ch9 is Comps := New_List ( Make_Component_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'P'), + Defining_Identifier => Make_Temporary (Loc, 'P'), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, @@ -5236,11 +5236,10 @@ package body Exp_Ch9 is Decl2 := Make_Full_Type_Declaration (Loc, Defining_Identifier => E_T, - Type_Definition => + Type_Definition => Make_Record_Definition (Loc, Component_List => - Make_Component_List (Loc, - Component_Items => Comps))); + Make_Component_List (Loc, Component_Items => Comps))); Insert_After (Decl1, Decl2); Analyze (Decl2); diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 4717d74..f857d0e 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -328,8 +328,8 @@ package body Exp_Dist is RPC_Receiver_Decl : Node_Id; -- Declaration for the RPC receiver entity associated with the - -- designated type. As an exception, for the case of an RACW that - -- implements a RAS, no object RPC receiver is generated. Instead, + -- designated type. As an exception, in the case of GARLIC, for an RACW + -- that implements a RAS, no object RPC receiver is generated. Instead, -- RPC_Receiver_Decl is the declaration after which the RPC receiver -- would have been inserted. @@ -559,14 +559,9 @@ package body Exp_Dist is -- call. Decls provides a location where variable declarations can be -- appended to construct the necessary values. - procedure Specific_Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id); - -- Build a components list for the stub type associated with an RACW type, - -- and build the necessary RPC receiver, if applicable. PCS-specific - -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration - -- is generated, then RPC_Receiver_Decl is set to Empty. + function Specific_RPC_Receiver_Decl + (RACW_Type : Entity_Id) return Node_Id; + -- Build the RPC receiver, for RACW, if applicable, else return Empty procedure Specific_Build_RPC_Receiver_Body (RPC_Receiver : Entity_Id; @@ -656,10 +651,7 @@ package body Exp_Dist is RCI_Locator : Entity_Id; Controlling_Parameter : Entity_Id) return RPC_Target; - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id); + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; function Build_Subprogram_Receiving_Stubs (Vis_Decl : Node_Id; @@ -733,10 +725,7 @@ package body Exp_Dist is RCI_Locator : Entity_Id; Controlling_Parameter : Entity_Id) return RPC_Target; - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id); + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id; function Build_Subprogram_Receiving_Stubs (Vis_Decl : Node_Id; @@ -1976,7 +1965,6 @@ package body Exp_Dist is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Designated_Type); - Stub_Type_Comps : List_Id; Stub_Type_Decl : Node_Id; Stub_Type_Access_Decl : Node_Id; @@ -1999,7 +1987,9 @@ package body Exp_Dist is Chars => New_External_Name (Related_Id => Chars (Stub_Type), Suffix => 'A')); - Specific_Build_Stub_Type (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + RPC_Receiver_Decl := Specific_RPC_Receiver_Decl (RACW_Type); + + -- Create new stub type, copying components from generic RACW_Stub_Type Stub_Type_Decl := Make_Full_Type_Declaration (Loc, @@ -2010,7 +2000,8 @@ package body Exp_Dist is Limited_Present => True, Component_List => Make_Component_List (Loc, - Component_Items => Stub_Type_Comps))); + Component_Items => + Copy_Component_List (RTE (RE_RACW_Stub_Type), Loc)))); -- Does the stub type need to explicitly implement interfaces from the -- designated type??? @@ -2041,7 +2032,10 @@ package body Exp_Dist is if Present (RPC_Receiver_Decl) then Append_To (Decls, RPC_Receiver_Decl); + else + -- Kludge, requires comment??? + RPC_Receiver_Decl := Last (Decls); end if; @@ -2399,7 +2393,6 @@ package body Exp_Dist is Limited_Present => True, Component_List => Make_Component_List (Loc, - Component_Items => New_List ( Make_Component_Declaration (Loc, Defining_Identifier => @@ -3874,7 +3867,7 @@ package body Exp_Dist is -- Compute distribution identifier Assign_Subprogram_Identifier - (Subp_Def, Current_Subp_Number, Subp_Val); + (Subp_Def, Current_Subp_Number, Subp_Val); pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def)); @@ -4711,72 +4704,6 @@ package body Exp_Dist is return Target_Info; end Build_Stub_Target; - --------------------- - -- Build_Stub_Type -- - --------------------- - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (RACW_Type); - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - - begin - Stub_Type_Comps := New_List ( - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Addr), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc)))); - - if Is_RAS then - RPC_Receiver_Decl := Empty; - else - declare - RPC_Receiver_Request : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_R); - begin - RPC_Receiver_Decl := - Make_Subprogram_Declaration (Loc, - Build_RPC_Receiver_Specification - (RPC_Receiver => Make_Temporary (Loc, 'R'), - Request_Parameter => RPC_Receiver_Request)); - end; - end if; - end Build_Stub_Type; - -------------------------------------- -- Build_Subprogram_Receiving_Stubs -- -------------------------------------- @@ -5253,6 +5180,28 @@ package body Exp_Dist is return Make_Identifier (Loc, Name_V); end Result; + ----------------------- + -- RPC_Receiver_Decl -- + ----------------------- + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + -- No RPC receiver for remote access-to-subprogram + + if Is_RAS then + return Empty; + end if; + + return + Make_Subprogram_Declaration (Loc, + Build_RPC_Receiver_Specification + (RPC_Receiver => Make_Temporary (Loc, 'R'), + Request_Parameter => Make_Defining_Identifier (Loc, Name_R))); + end RPC_Receiver_Decl; + ---------------------- -- Stream_Parameter -- ---------------------- @@ -7659,46 +7608,6 @@ package body Exp_Dist is return Target_Info; end Build_Stub_Target; - --------------------- - -- Build_Stub_Type -- - --------------------- - - procedure Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (RACW_Type); - - begin - Stub_Type_Comps := New_List ( - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Target), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc)))); - - RPC_Receiver_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'R'), - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Servant), Loc)); - end Build_Stub_Type; - ----------------------------- -- Build_RPC_Receiver_Body -- ----------------------------- @@ -11160,6 +11069,21 @@ package body Exp_Dist is Overload_Counter_Table.Set (Name_Find, 1); end Reserve_NamingContext_Methods; + ----------------------- + -- RPC_Receiver_Decl -- + ----------------------- + + function RPC_Receiver_Decl (RACW_Type : Entity_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + begin + return + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'R'), + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (RTE (RE_Servant), Loc)); + end RPC_Receiver_Decl; + end PolyORB_Support; ------------------------------- @@ -11514,26 +11438,22 @@ package body Exp_Dist is end case; end Specific_Build_Stub_Target; - ------------------------------ - -- Specific_Build_Stub_Type -- - ------------------------------ + -------------------------------- + -- Specific_RPC_Receiver_Decl -- + -------------------------------- - procedure Specific_Build_Stub_Type - (RACW_Type : Entity_Id; - Stub_Type_Comps : out List_Id; - RPC_Receiver_Decl : out Node_Id) + function Specific_RPC_Receiver_Decl + (RACW_Type : Entity_Id) return Node_Id is begin case Get_PCS_Name is when Name_PolyORB_DSA => - PolyORB_Support.Build_Stub_Type - (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + return PolyORB_Support.RPC_Receiver_Decl (RACW_Type); when others => - GARLIC_Support.Build_Stub_Type - (RACW_Type, Stub_Type_Comps, RPC_Receiver_Decl); + return GARLIC_Support.RPC_Receiver_Decl (RACW_Type); end case; - end Specific_Build_Stub_Type; + end Specific_RPC_Receiver_Decl; ----------------------------------------------- -- Specific_Build_Subprogram_Receiving_Stubs -- diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index a64c0d7..e807864 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -361,10 +361,13 @@ package body Freeze is -- For simple renamings, subsequent calls can be expanded directly as -- calls to the renamed entity. The body must be generated in any case - -- for calls that may appear elsewhere. + -- for calls that may appear elsewhere. This is not done in the case + -- where the subprogram is an instantiation because the actual proper + -- body has not been built yet. if Ekind_In (Old_S, E_Function, E_Procedure) and then Nkind (Decl) = N_Subprogram_Declaration + and then not Is_Generic_Instance (Old_S) then Set_Body_To_Inline (Decl, Old_S); end if; diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 666d251..7e9ff7d 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -1014,7 +1014,8 @@ by any part of the GNAT compiler, except to generate corresponding note lines in the generated ALI file. For the format of these note lines, see the compiler source file lib-writ.ads. This pragma is intended for use by external tools, including ASIS@. The use of pragma Annotate does not -affect the compilation process in any way. +affect the compilation process in any way. This pragma may be used as +a configuration pragma. @node Pragma Assert @unnumberedsec Pragma Assert diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index e177167..6d9138c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -5735,7 +5735,7 @@ as shown in the following example. This switch activates warnings for use of @code{pragma Warnings (Off, entity)} where either the pragma is entirely useless (because it suppresses no warnings), or it could be replaced by @code{pragma Unreferenced} or -@code{pragma Unmodified}.The default is that these warnings are not given. +@code{pragma Unmodified}. The default is that these warnings are not given. Note that this warning is not included in -gnatwa, it must be activated explicitly. @@ -11591,6 +11591,7 @@ recognized by GNAT: Ada_2005 Ada_12 Ada_2012 + Annotate Assertion_Policy Assume_No_Invalid_Values C_Pass_By_Copy @@ -17578,7 +17579,7 @@ Same as @option{^-gnatyM^/MAX_LINE_LENGTH=^@var{n}} @item ^--no-exception^/NO_EXCEPTION^ @cindex @option{^--no-exception^/NO_EXCEPTION^} (@command{gnatstub}) -void raising PROGRAM_ERROR in the generated bodies of program unit stubs. +Avoid raising PROGRAM_ERROR in the generated bodies of program unit stubs. This is not always possible for function stubs. @item ^--no-local-header^/NO_LOCAL_HEADER^ diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index f50406f..35cfdfc 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1010,8 +1010,17 @@ package body Lib.Xref is if Alfa_Mode then Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); - Ent_Scope_File := Get_Source_Unit (Ent_Scope); + -- Since we are reaching through renamings in Alfa mode, we may + -- end up with standard constants. Ignore those. + + if Sloc (Ent_Scope) <= Standard_Location + or else Def <= Standard_Location + then + return; + end if; + + Ent_Scope_File := Get_Source_Unit (Ent_Scope); else Ref_Scope := Empty; Ent_Scope := Empty; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 7b772d0..ddbede2 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1163,6 +1163,7 @@ package Rtsfind is RE_Get_RACW, -- System.Partition_Interface RE_Get_RCI_Package_Receiver, -- System.Partition_Interface RE_Get_Unique_Remote_Pointer, -- System.Partition_Interface + RE_RACW_Stub_Type, -- System.Partition_Interface RE_RACW_Stub_Type_Access, -- System.Partition_Interface RE_RAS_Proxy_Type_Access, -- System.Partition_Interface RE_Raise_Program_Error_Unknown_Tag, -- System.Partition_Interface @@ -2357,6 +2358,7 @@ package Rtsfind is RE_Get_RACW => System_Partition_Interface, RE_Get_RCI_Package_Receiver => System_Partition_Interface, RE_Get_Unique_Remote_Pointer => System_Partition_Interface, + RE_RACW_Stub_Type => System_Partition_Interface, RE_RACW_Stub_Type_Access => System_Partition_Interface, RE_RAS_Proxy_Type_Access => System_Partition_Interface, RE_Raise_Program_Error_Unknown_Tag => System_Partition_Interface, diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index 391866c..2bd15a8 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -108,7 +108,7 @@ package System.OS_Interface is SIGUSR1 : constant := 30; -- user defined signal 1 SIGUSR2 : constant := 31; -- user defined signal 2 - SIGADAABORT : constant := SIGTERM; + SIGADAABORT : constant := SIGABRT; -- Change this if you want to use another signal for task abort. -- SIGTERM might be a good one. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1419b76..dbf3896 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4454,9 +4454,20 @@ package body Sem_Ch12 is Set_Contract (Anon_Id, Make_Contract (Sloc (Anon_Id))); -- ??? needed? Set_Contract (Act_Decl_Id, Make_Contract (Sloc (Act_Decl_Id))); + -- Inherit all inlining-related flags which apply to the generic in + -- the subprogram and its declaration. + Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit)); Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit)); + Set_Has_Pragma_Inline (Act_Decl_Id, Has_Pragma_Inline (Gen_Unit)); + Set_Has_Pragma_Inline (Anon_Id, Has_Pragma_Inline (Gen_Unit)); + + Set_Has_Pragma_Inline_Always + (Act_Decl_Id, Has_Pragma_Inline_Always (Gen_Unit)); + Set_Has_Pragma_Inline_Always + (Anon_Id, Has_Pragma_Inline_Always (Gen_Unit)); + if not Is_Intrinsic_Subprogram (Gen_Unit) then Check_Elab_Instantiation (N); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index be22377..fdd4b1f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2302,10 +2302,12 @@ package body Sem_Ch5 is Typ : Entity_Id; begin - -- In semantics mode, introduce loop variable so that loop body can be - -- properly analyzed. Otherwise this is one after expansion. + -- In semantics and Alfa modes, introduce loop variable so that loop + -- body can be properly analyzed. Otherwise this is one after expansion. - if Operating_Mode = Check_Semantics then + if Operating_Mode = Check_Semantics + or else Alfa_Mode + then Enter_Name (Def_Id); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 8bbffd9..26d90af 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2265,6 +2265,39 @@ package body Sem_Util is end Conditional_Delay; ------------------------- + -- Copy_Component_List -- + ------------------------- + + function Copy_Component_List + (R_Typ : Entity_Id; + Loc : Source_Ptr) return List_Id + is + Comp : Node_Id; + Comps : constant List_Id := New_List; + begin + Comp := First_Component (Underlying_Type (R_Typ)); + + while Present (Comp) loop + if Comes_From_Source (Comp) then + declare + Comp_Decl : constant Node_Id := Declaration_Node (Comp); + begin + Append_To (Comps, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (Comp)), + Component_Definition => + New_Copy_Tree + (Component_Definition (Comp_Decl), New_Sloc => Loc))); + end; + end if; + Next_Component (Comp); + end loop; + + return Comps; + end Copy_Component_List; + + ------------------------- -- Copy_Parameter_List -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 55a2310..77f26b4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -272,6 +272,13 @@ package Sem_Util is -- of inlining, and for private protected ops. Also used to create bodies -- for stubbed subprograms. + function Copy_Component_List + (R_Typ : Entity_Id; + Loc : Source_Ptr) return List_Id; + -- Copy components from record type R_Typ that come from source. Used to + -- create a new compatible record type. Loc is the source location assigned + -- to the created nodes. + function Current_Entity (N : Node_Id) return Entity_Id; pragma Inline (Current_Entity); -- Find the currently visible definition for a given identifier, that is to diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index a68e5e8..5f321db 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -347,6 +347,7 @@ package Snames is Name_Ada_2005 : constant Name_Id := N + $; -- GNAT Name_Ada_12 : constant Name_Id := N + $; -- GNAT Name_Ada_2012 : constant Name_Id := N + $; -- GNAT + Name_Annotate : constant Name_Id := N + $; -- GNAT Name_Assertion_Policy : constant Name_Id := N + $; -- Ada 05 Name_Assume_No_Invalid_Values : constant Name_Id := N + $; -- GNAT Name_C_Pass_By_Copy : constant Name_Id := N + $; -- GNAT @@ -418,7 +419,6 @@ package Snames is Name_Abort_Defer : constant Name_Id := N + $; -- GNAT Name_All_Calls_Remote : constant Name_Id := N + $; - Name_Annotate : constant Name_Id := N + $; -- GNAT -- Note: AST_Entry is not in this list because its name matches -- VMS -- the name of the corresponding attribute. However, it is @@ -1520,6 +1520,7 @@ package Snames is Pragma_Ada_2005, Pragma_Ada_12, Pragma_Ada_2012, + Pragma_Annotate, Pragma_Assertion_Policy, Pragma_Assume_No_Invalid_Values, Pragma_C_Pass_By_Copy, @@ -1583,7 +1584,6 @@ package Snames is Pragma_Abort_Defer, Pragma_All_Calls_Remote, - Pragma_Annotate, Pragma_Assert, Pragma_Asynchronous, Pragma_Atomic, |