+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.
------------------------------------------------------------------------------
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 --
-----------------------
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;
return Cursor'(Container'Unrestricted_Access, Node);
end Find;
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Object.Position;
+ end First;
+
-----------------
-- First_Child --
-----------------
is
begin
Container.Nodes (Index) :=
- (Parent => -1,
+ (Parent => No_Node,
Prev => 0,
Next => 0,
Children => (others => 0));
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 --
----------------------
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 --
------------------
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 --
--------------------
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;
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Iterator_Interfaces;
private with Ada.Streams;
generic
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;
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;
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;
(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));
(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;
Process : not null access procedure (Position : Cursor));
private
+ use Ada.Streams;
type Children_Type is record
First : Count_Type'Base;
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 => <>);
Count : Count_Type := 0;
end record;
- use Ada.Streams;
-
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Tree);
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 => <>);
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 --
-----------------------
return Cursor'(Container'Unrestricted_Access, N);
end Find;
+ -----------
+ -- First --
+ -----------
+
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Object.Position;
+ end First;
+
-----------------
-- First_Child --
-----------------
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 --
----------------------
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 --
------------------
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 --
--------------------
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;
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Iterator_Interfaces;
private with Ada.Finalization;
private with Ada.Streams;
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;
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;
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;
(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));
(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;
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 => <>);
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 --
-----------------------
return Cursor'(Container'Unrestricted_Access, N);
end Find;
+ -----------
+ -- First --
+ -----------
+
+ function First (Object : Iterator) return Cursor is
+ begin
+ return Object.Position;
+ end First;
+
-----------------
-- First_Child --
-----------------
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 --
----------------------
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 --
------------------
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 --
--------------------
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;
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
+with Ada.Iterator_Interfaces;
private with Ada.Finalization;
private with Ada.Streams;
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;
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;
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;
(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));
(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;
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 => <>);
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;
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
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;
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 --
-------------------------------------------
-- 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
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.
-- 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;
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 --
-----------------------------------
-- 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
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,
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);
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.
-- 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;
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;
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;
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;
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,
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???
if Present (RPC_Receiver_Decl) then
Append_To (Decls, RPC_Receiver_Decl);
+
else
+ -- Kludge, requires comment???
+
RPC_Receiver_Decl := Last (Decls);
end if;
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
-
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
-- 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));
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 --
--------------------------------------
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 --
----------------------
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 --
-----------------------------
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;
-------------------------------
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 --
-- 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;
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
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.
Ada_2005
Ada_12
Ada_2012
+ Annotate
Assertion_Policy
Assume_No_Invalid_Values
C_Pass_By_Copy
@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^
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;
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
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,
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.
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;
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;
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 --
-------------------------
-- 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
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
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
Pragma_Ada_2005,
Pragma_Ada_12,
Pragma_Ada_2012,
+ Pragma_Annotate,
Pragma_Assertion_Policy,
Pragma_Assume_No_Invalid_Values,
Pragma_C_Pass_By_Copy,
Pragma_Abort_Defer,
Pragma_All_Calls_Remote,
- Pragma_Annotate,
Pragma_Assert,
Pragma_Asynchronous,
Pragma_Atomic,
projects / platform / upstream / gcc.git / commitdiff