+2011-08-31 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb,
+ lib-xref-alfa.adb: Minor reformatting.
+
+2011-08-31 Matthew Heaney <heaney@adacore.com>
+
+ * a-crbltr.ads (Tree_Type): Default-initialize the Nodes component.
+
+2011-08-31 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch4.adb (Try_Object_Operation): Addition of one formal to search
+ only for class-wide subprograms conflicting with entities of concurrent
+ tagged types.
+
+2011-08-31 Matthew Heaney <heaney@adacore.com>
+
+ * a-rbtgbo.adb (Generic_Allocate): Initialize pointer components of
+ node to null value.
+
+2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb (Insert_Freeze_Node_For_Instance): Provide a more
+ general description of the routine.
+
+2011-08-31 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cbdlli.adb, a-cbdlli.ads: Add iterator machinery to bounded
+ doubly-linked lists.
+
2011-08-31 Gary Dismukes <dismukes@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant
with System; use type System.Address;
package body Ada.Containers.Bounded_Doubly_Linked_Lists is
+ type Iterator is new
+ List_Iterator_Interfaces.Reversible_Iterator with record
+ Container : List_Access;
+ Node : Count_Type;
+ end record;
+
+ overriding function First (Object : Iterator) return Cursor;
+ overriding function Last (Object : Iterator) return Cursor;
+
+ overriding function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
+
+ overriding function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor;
-----------------------
-- Local Subprograms --
return Cursor'(Container'Unrestricted_Access, Container.First);
end First;
+ function First (Object : Iterator) return Cursor is
+ begin
+ if Object.Container = null then
+ return No_Element;
+ else
+ return (Object.Container, Object.Container.First);
+ end if;
+ end First;
+
-------------------
-- First_Element --
-------------------
B := B - 1;
end Iterate;
+ function Iterate (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ begin
+ if Container.Length = 0 then
+ return Iterator'(null, Count_Type'First);
+ else
+ return Iterator'(Container'Unrestricted_Access, Container.First);
+ end if;
+ end Iterate;
+
+ function Iterate (Container : List; Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
+ is
+ It : constant Iterator := (Container'Unrestricted_Access, Start.Node);
+ begin
+ return It;
+ end Iterate;
+
----------
-- Last --
----------
return Cursor'(Container'Unrestricted_Access, Container.Last);
end Last;
+ function Last (Object : Iterator) return Cursor is
+ begin
+ if Object.Container = null then
+ return No_Element;
+ else
+ return (Object.Container, Object.Container.Last);
+ end if;
+ end Last;
+
------------------
-- Last_Element --
------------------
end;
end Next;
+ function Next
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is
+ Nodes : Node_Array renames Position.Container.Nodes;
+ Node : constant Count_Type := Nodes (Position.Node).Next;
+ begin
+ if Position.Node = Object.Container.Last then
+ return No_Element;
+ else
+ return (Object.Container, Node);
+ end if;
+ end Next;
+
-------------
-- Prepend --
-------------
end;
end Previous;
+ function Previous
+ (Object : Iterator;
+ Position : Cursor) return Cursor
+ is
+ Nodes : Node_Array renames Position.Container.Nodes;
+ Node : constant Count_Type := Nodes (Position.Node).Prev;
+ begin
+ if Position.Node = 0 then
+ return No_Element;
+ else
+ return (Object.Container, Node);
+ end if;
+ end Previous;
+
-------------------
-- Query_Element --
-------------------
raise Program_Error with "attempt to stream list cursor";
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 : List; Position : Cursor)
+ return Constant_Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element =>
+ Position.Container.Nodes (Position.Node).Element'Unrestricted_Access);
+ end Constant_Reference;
+
+ function Reference (Container : List; Position : Cursor)
+ return Reference_Type is
+ begin
+ pragma Unreferenced (Container);
+
+ if Position.Container = null then
+ raise Constraint_Error with "Position cursor has no element";
+ end if;
+
+ return (Element =>
+ Position.Container.Nodes (Position.Node).Element'Unrestricted_Access);
+ end Reference;
+
---------------------
-- Replace_Element --
---------------------
raise Program_Error with "attempt to stream list cursor";
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_Doubly_Linked_Lists;
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-private with Ada.Streams;
+with Ada.Streams; use Ada.Streams;
+with Ada.Iterator_Interfaces;
generic
type Element_Type is private;
pragma Pure;
pragma Remote_Types;
- type List (Capacity : Count_Type) is tagged private;
+ type List (Capacity : Count_Type) is tagged private
+ with
+ Constant_Indexing => Constant_Reference,
+ Variable_Indexing => Reference,
+ Default_Iterator => Iterate,
+ Iterator_Element => Element_Type;
+
pragma Preelaborable_Initialization (List);
type Cursor is private;
Empty_List : constant List;
No_Element : constant Cursor;
+ function Has_Element (Position : Cursor) return Boolean;
+
+ package List_Iterator_Interfaces is new
+ Ada.Iterator_Interfaces (Cursor, Has_Element);
function "=" (Left, Right : List) return Boolean;
procedure Reverse_Elements (Container : in out List);
+ function Iterate (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
+ function Iterate (Container : List; Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class;
+
procedure Swap
(Container : in out List;
I, J : Cursor);
(Container : List;
Item : Element_Type) return Boolean;
- function Has_Element (Position : Cursor) return Boolean;
-
procedure Iterate
(Container : List;
Process : not null access procedure (Position : Cursor));
end Generic_Sorting;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ 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;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is
+ private
+ with
+ Implicit_Dereference => Element;
+
+ 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 : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Constant_Reference_Type;
+
+ function Reference
+ (Container : List; Position : Cursor) -- SHOULD BE ALIASED
+ return Reference_Type;
+
private
pragma Inline (Next);
Lock : Natural := 0;
end record;
- use Ada.Streams;
-
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out List);
for Cursor'Write use Write;
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is null record;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is null record;
+
Empty_List : constant List := (Capacity => 0, others => <>);
No_Element : constant Cursor := Cursor'(null, 0);
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package Generic_Bounded_Tree_Types is
type Nodes_Type is array (Count_Type range <>) of Node_Type;
+ -- Note that objects of type Tree_Type are logically initialized (in the
+ -- sense that representation invariants of type are satisfied by dint of
+ -- default initialization), even without the Nodes component also having
+ -- its own initialization expression. We only initializae the Nodes
+ -- component here in order to prevent spurious compiler warnings about
+ -- the container object not being fully initialized.
+
type Tree_Type (Capacity : Count_Type) is tagged record
First : Count_Type := 0;
Last : Count_Type := 0;
Busy : Natural := 0;
Lock : Natural := 0;
Free : Count_Type'Base := -1;
- Nodes : Nodes_Type (1 .. Capacity);
+ Nodes : Nodes_Type (1 .. Capacity) := (others => <>);
end record;
end Generic_Bounded_Tree_Types;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Set_Element (N (Node));
Tree.Free := Tree.Free - 1;
end if;
+
+ Set_Parent (N (Node), Parent => 0);
+ Set_Left (N (Node), Left => 0);
+ Set_Right (N (Node), Right => 0);
end Generic_Allocate;
-------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Name_Step : Name_Id;
begin
-
-- The type of the iterator is the return type of the Iterate
-- function used. For the "of" form this is the default iterator
-- for the type, otherwise it is the type of the explicit
-- use-visible, so we introduce the name of the enclosing package
-- in the declarations below. The Iterator type is declared in a
-- an instance within the container package itself.
+
-- If the container type is a derived type, the cursor type is
-- found in the package of the parent type.
else
Pack := Scope (Scope (Container_Typ));
end if;
+
else
if Is_Derived_Type (Container_Typ) then
Pack := Scope (Root_Type (Container_Typ));
function Is_Alfa_Reference
(E : Entity_Id;
- Typ : Character) return Boolean is
+ Typ : Character) return Boolean
+ is
begin
-- The only references of interest on callable entities are calls.
-- On non-callable entities, the only references of interest are
Include_Compatible_Languages => No_Name_List,
Compiler_Driver => No_File,
Compiler_Driver_Path => null,
- Compiler_Leading_Required_Switches => No_Name_List,
- Compiler_Trailing_Required_Switches => No_Name_List,
+ Compiler_Leading_Required_Switches
+ => No_Name_List,
+ Compiler_Trailing_Required_Switches
+ => No_Name_List,
Multi_Unit_Switches => No_Name_List,
Multi_Unit_Object_Separator => ' ',
Path_Syntax => Canonical,
end if;
end Check_Local;
- -- The attribute ppears within a pre/postcondition, but refers to
+ -- The attribute appears within a pre/postcondition, but refers to
-- an entity in the enclosing subprogram. If it is a component of a
-- formal its expansion might generate actual subtypes that may be
-- referenced in an inner context, and which must be elaborated
procedure Insert_Freeze_Node_For_Instance
(N : Node_Id;
F_Node : Node_Id);
- -- N is an instance and F_Node is its corresponding freeze node. Insert
- -- F_Node depending on the enclosing context and placement of N in the
- -- following manner:
- --
- -- 1) N is a package instance - Attempt to insert the freeze node before
- -- a source package or subprogram body which follows immediately after N.
- -- If no such body is found, perform the actions in 2).
- --
- -- 2) N is a subprogram instance or a package instance not followed by
- -- a source body - Insert the freeze node at the end of the declarations
- -- list which contains N. If N is in the visible part of an enclosing
- -- package declaration, the freeze node is inserted at the end of the
- -- private declarations.
+ -- N denotes a package or a subprogram instantiation and F_Node is the
+ -- associated freeze node. Insert the freeze node before the first source
+ -- body which follows immediately after N. If no such body is found, the
+ -- freeze node is inserted at the end of the declarative region which
+ -- contains N.
procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id;
elsif Nkind (Parent (N)) = N_Package_Body
and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
then
-
declare
Enclosing : constant Entity_Id :=
Corresponding_Spec (Parent (N));
Ensure_Freeze_Node (Enclosing);
if not Is_List_Member (Freeze_Node (Enclosing)) then
- Insert_After (Freeze_Node (Par), Freeze_Node (Enclosing));
+
+ -- The enclosing context is a subunit, insert the freeze
+ -- node after the stub.
+
+ if Nkind (Parent (Parent (N))) = N_Subunit then
+ Insert_Freeze_Node_For_Instance
+ (Corresponding_Stub (Parent (Parent (N))),
+ Freeze_Node (Enclosing));
+
+ -- The parent instance has been frozen before the body of
+ -- the enclosing package, insert the freeze node after
+ -- the body.
+
+ elsif List_Containing (Freeze_Node (Par)) =
+ List_Containing (Parent (N))
+ and then Sloc (Freeze_Node (Par)) < Sloc (Parent (N))
+ then
+ Insert_Freeze_Node_For_Instance
+ (Parent (N), Freeze_Node (Enclosing));
+
+ else
+ Insert_After
+ (Freeze_Node (Par), Freeze_Node (Enclosing));
+ end if;
end if;
end;
-- subprogram, and the call F (X) interpreted as F.all (X). In this case
-- the call may be overloaded with both interpretations.
- function Try_Object_Operation (N : Node_Id) return Boolean;
+ function Try_Object_Operation
+ (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean;
-- Ada 2005 (AI-252): Support the object.operation notation. If node N
-- is a call in this notation, it is transformed into a normal subprogram
-- call where the prefix is a parameter, and True is returned. If node
- -- N is not of this form, it is unchanged, and False is returned.
+ -- N is not of this form, it is unchanged, and False is returned. if
+ -- CW_Test_Only is true then N is an N_Selected_Component node which
+ -- is part of a call to an entry or procedure of a tagged concurrent
+ -- type and this routine is invoked to search for class-wide subprograms
+ -- conflicting with the target entity.
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
then
return;
end if;
+
+ -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
+ -- entry or procedure of a tagged concurrent type we must check
+ -- if there are class-wide subprograms covering the primitive. If
+ -- true then Try_Object_Operation reports the error.
+
+ if Has_Candidate
+ and then Is_Concurrent_Type (Prefix_Type)
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+
+ -- Duplicate the call. This is required to avoid problems with
+ -- the tree transformations performed by Try_Object_Operation.
+
+ and then Try_Object_Operation
+ (N => Sinfo.Name (New_Copy_Tree (Parent (N))),
+ CW_Test_Only => True)
+ then
+ return;
+ end if;
end if;
if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
-- Try_Object_Operation --
--------------------------
- function Try_Object_Operation (N : Node_Id) return Boolean is
+ function Try_Object_Operation
+ (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
+ is
K : constant Node_Kind := Nkind (Parent (N));
Is_Subprg_Call : constant Boolean := Nkind_In
(K, N_Procedure_Call_Statement,
----------------------
procedure Report_Ambiguity (Op : Entity_Id) is
- Access_Formal : constant Boolean :=
- Is_Access_Type (Etype (First_Formal (Op)));
Access_Actual : constant Boolean :=
Is_Access_Type (Etype (Prefix (N)));
+ Access_Formal : Boolean := False;
begin
Error_Msg_Sloc := Sloc (Op);
+ if Present (First_Formal (Op)) then
+ Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
+ end if;
+
if Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
-- Start of processing for Try_Class_Wide_Operation
begin
+ -- If we are searching only for conflicting class-wide subprograms
+ -- then initialize directly Matching_Op with the target entity.
+
+ if CW_Test_Only then
+ Matching_Op := Entity (Selector_Name (N));
+ end if;
+
-- Loop through ancestor types (including interfaces), traversing
-- the homonym chain of the subprogram, trying out those homonyms
-- whose first formal has the class-wide type of the ancestor, or
pragma Unreferenced (CW_Result);
begin
- Prim_Result :=
- Try_Primitive_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace);
+ if not CW_Test_Only then
+ Prim_Result :=
+ Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
-- Check if there is a class-wide subprogram covering the
-- primitive. This check must be done even if a candidate
end if;
if Etype (New_Call_Node) /= Any_Type then
- Complete_Object_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace);
- return True;
+
+ -- No need to complete the tree transformations if we are only
+ -- searching for conflicting class-wide subprograms
+
+ if CW_Test_Only then
+ return False;
+ else
+ Complete_Object_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ return True;
+ end if;
elsif Present (Candidate) then
projects / platform / upstream / gcc.git / commitdiff