[multiple changes]
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. From-SVN: r178363
This commit is contained in:
Arnaud Charlet
parent
0bb3bfb8fe
commit
8cf23b9188
@ -1,3 +1,33 @@
|
||||
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
|
||||
|
||||
@ -30,6 +30,22 @@
|
||||
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 --
|
||||
@ -526,6 +542,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
-------------------
|
||||
@ -1030,6 +1055,25 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
----------
|
||||
@ -1043,6 +1087,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
------------------
|
||||
@ -1133,6 +1186,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
-------------
|
||||
@ -1175,6 +1242,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
-------------------
|
||||
@ -1257,6 +1338,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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 --
|
||||
---------------------
|
||||
@ -2001,4 +2128,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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 --
|
||||
@ -31,7 +31,8 @@
|
||||
-- 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;
|
||||
@ -43,7 +44,13 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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;
|
||||
@ -52,6 +59,10 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
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;
|
||||
|
||||
@ -129,6 +140,12 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
|
||||
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);
|
||||
@ -183,8 +200,6 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
(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));
|
||||
@ -205,6 +220,48 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
|
||||
|
||||
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);
|
||||
@ -228,8 +285,6 @@ private
|
||||
Lock : Natural := 0;
|
||||
end record;
|
||||
|
||||
use Ada.Streams;
|
||||
|
||||
procedure Read
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Item : out List);
|
||||
@ -263,6 +318,12 @@ private
|
||||
|
||||
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);
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -53,6 +53,13 @@ package Ada.Containers.Red_Black_Trees is
|
||||
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;
|
||||
@ -61,7 +68,7 @@ package Ada.Containers.Red_Black_Trees is
|
||||
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;
|
||||
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -586,6 +586,10 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
|
||||
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;
|
||||
|
||||
-------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
|
||||
@ -3012,7 +3012,6 @@ package body Exp_Ch5 is
|
||||
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
|
||||
@ -3023,6 +3022,7 @@ package body Exp_Ch5 is
|
||||
-- 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.
|
||||
|
||||
@ -3034,6 +3034,7 @@ package body Exp_Ch5 is
|
||||
else
|
||||
Pack := Scope (Scope (Container_Typ));
|
||||
end if;
|
||||
|
||||
else
|
||||
if Is_Derived_Type (Container_Typ) then
|
||||
Pack := Scope (Root_Type (Container_Typ));
|
||||
|
||||
@ -594,7 +594,8 @@ package body Alfa is
|
||||
|
||||
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
|
||||
|
||||
@ -580,8 +580,10 @@ package Prj is
|
||||
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,
|
||||
|
||||
@ -3860,7 +3860,7 @@ package body Sem_Attr is
|
||||
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
|
||||
|
||||
@ -519,19 +519,11 @@ package body Sem_Ch12 is
|
||||
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;
|
||||
@ -7586,7 +7578,6 @@ package body Sem_Ch12 is
|
||||
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));
|
||||
@ -7596,7 +7587,30 @@ package body Sem_Ch12 is
|
||||
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;
|
||||
|
||||
|
||||
@ -276,11 +276,16 @@ package body Sem_Ch4 is
|
||||
-- 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);
|
||||
@ -4165,6 +4170,25 @@ package body Sem_Ch4 is
|
||||
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
|
||||
@ -6609,7 +6633,9 @@ package body Sem_Ch4 is
|
||||
-- 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,
|
||||
@ -6898,14 +6924,17 @@ package body Sem_Ch4 is
|
||||
----------------------
|
||||
|
||||
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
|
||||
@ -7205,6 +7234,13 @@ package body Sem_Ch4 is
|
||||
-- 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
|
||||
@ -7286,10 +7322,12 @@ package body Sem_Ch4 is
|
||||
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
|
||||
@ -7663,10 +7701,18 @@ package body Sem_Ch4 is
|
||||
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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user