OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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 2011-08-31 11:07:20 +02:00
parent 0bb3bfb8fe
commit 8cf23b9188
12 changed files with 353 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
gcc/ada/ChangeLog
View File

@ -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> 2011-08-31 Gary Dismukes <dismukes@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant * exp_ch5.adb (Expand_N_Assignment_Statement): When a discriminant

143
gcc/ada/a-cbdlli.adb
View File

@ -30,6 +30,22 @@
with System; use type System.Address; with System; use type System.Address;
package body Ada.Containers.Bounded_Doubly_Linked_Lists is 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 -- -- Local Subprograms --
@ -526,6 +542,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return Cursor'(Container'Unrestricted_Access, Container.First); return Cursor'(Container'Unrestricted_Access, Container.First);
end 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 -- -- First_Element --
------------------- -------------------
@ -1030,6 +1055,25 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
B := B - 1; B := B - 1;
end Iterate; 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 -- -- Last --
---------- ----------
@ -1043,6 +1087,15 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
return Cursor'(Container'Unrestricted_Access, Container.Last); return Cursor'(Container'Unrestricted_Access, Container.Last);
end 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 -- -- Last_Element --
------------------ ------------------
@ -1133,6 +1186,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
end; end;
end Next; 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 -- -- Prepend --
------------- -------------
@ -1175,6 +1242,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
end; end;
end Previous; 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 -- -- Query_Element --
------------------- -------------------
@ -1257,6 +1338,52 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Program_Error with "attempt to stream list cursor"; raise Program_Error with "attempt to stream list cursor";
end Read; 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 -- -- Replace_Element --
--------------------- ---------------------
@ -2001,4 +2128,20 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
raise Program_Error with "attempt to stream list cursor"; raise Program_Error with "attempt to stream list cursor";
end Write; 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; end Ada.Containers.Bounded_Doubly_Linked_Lists;

75
gcc/ada/a-cbdlli.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
@ -31,7 +31,8 @@
-- This unit was originally developed by Matthew J Heaney. -- -- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
private with Ada.Streams; with Ada.Streams; use Ada.Streams;
with Ada.Iterator_Interfaces;
generic generic
type Element_Type is private; type Element_Type is private;
@ -43,7 +44,13 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Pure; pragma Pure;
pragma Remote_Types; 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); pragma Preelaborable_Initialization (List);
type Cursor is private; type Cursor is private;
@ -52,6 +59,10 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
Empty_List : constant List; Empty_List : constant List;
No_Element : constant Cursor; 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; 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); 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 procedure Swap
(Container : in out List; (Container : in out List;
I, J : Cursor); I, J : Cursor);
@ -183,8 +200,6 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
(Container : List; (Container : List;
Item : Element_Type) return Boolean; Item : Element_Type) return Boolean;
function Has_Element (Position : Cursor) return Boolean;
procedure Iterate procedure Iterate
(Container : List; (Container : List;
Process : not null access procedure (Position : Cursor)); Process : not null access procedure (Position : Cursor));
@ -205,6 +220,48 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
end Generic_Sorting; 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 private
pragma Inline (Next); pragma Inline (Next);
@ -228,8 +285,6 @@ private
Lock : Natural := 0; Lock : Natural := 0;
end record; end record;
use Ada.Streams;
procedure Read procedure Read
(Stream : not null access Root_Stream_Type'Class; (Stream : not null access Root_Stream_Type'Class;
Item : out List); Item : out List);
@ -263,6 +318,12 @@ private
for Cursor'Write use Write; 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 => <>); Empty_List : constant List := (Capacity => 0, others => <>);
No_Element : constant Cursor := Cursor'(null, 0); No_Element : constant Cursor := Cursor'(null, 0);

11
gcc/ada/a-crbltr.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- 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 package Generic_Bounded_Tree_Types is
type Nodes_Type is array (Count_Type range <>) of Node_Type; 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 type Tree_Type (Capacity : Count_Type) is tagged record
First : Count_Type := 0; First : Count_Type := 0;
Last : Count_Type := 0; Last : Count_Type := 0;
@ -61,7 +68,7 @@ package Ada.Containers.Red_Black_Trees is
Busy : Natural := 0; Busy : Natural := 0;
Lock : Natural := 0; Lock : Natural := 0;
Free : Count_Type'Base := -1; Free : Count_Type'Base := -1;
Nodes : Nodes_Type (1 .. Capacity); Nodes : Nodes_Type (1 .. Capacity) := (others => <>);
end record; end record;
end Generic_Bounded_Tree_Types; end Generic_Bounded_Tree_Types;

6
gcc/ada/a-rbtgbo.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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)); Set_Element (N (Node));
Tree.Free := Tree.Free - 1; Tree.Free := Tree.Free - 1;
end if; end if;
Set_Parent (N (Node), Parent => 0);
Set_Left (N (Node), Left => 0);
Set_Right (N (Node), Right => 0);
end Generic_Allocate; end Generic_Allocate;
------------------- -------------------

2
gcc/ada/exp_alfa.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --

3
gcc/ada/exp_ch5.adb
View File

@ -3012,7 +3012,6 @@ package body Exp_Ch5 is
Name_Step : Name_Id; Name_Step : Name_Id;
begin begin
-- The type of the iterator is the return type of the Iterate -- The type of the iterator is the return type of the Iterate
-- function used. For the "of" form this is the default iterator -- function used. For the "of" form this is the default iterator
-- for the type, otherwise it is the type of the explicit -- 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 -- use-visible, so we introduce the name of the enclosing package
-- in the declarations below. The Iterator type is declared in a -- in the declarations below. The Iterator type is declared in a
-- an instance within the container package itself. -- an instance within the container package itself.
-- If the container type is a derived type, the cursor type is -- If the container type is a derived type, the cursor type is
-- found in the package of the parent type. -- found in the package of the parent type.
@ -3034,6 +3034,7 @@ package body Exp_Ch5 is
else else
Pack := Scope (Scope (Container_Typ)); Pack := Scope (Scope (Container_Typ));
end if; end if;
else else
if Is_Derived_Type (Container_Typ) then if Is_Derived_Type (Container_Typ) then
Pack := Scope (Root_Type (Container_Typ)); Pack := Scope (Root_Type (Container_Typ));

3
gcc/ada/lib-xref-alfa.adb
View File

@ -594,7 +594,8 @@ package body Alfa is
function Is_Alfa_Reference function Is_Alfa_Reference
(E : Entity_Id; (E : Entity_Id;
Typ : Character) return Boolean is Typ : Character) return Boolean
is
begin begin
-- The only references of interest on callable entities are calls. -- The only references of interest on callable entities are calls.
-- On non-callable entities, the only references of interest are -- On non-callable entities, the only references of interest are

6
gcc/ada/prj.ads
View File

@ -580,8 +580,10 @@ package Prj is
Include_Compatible_Languages => No_Name_List, Include_Compatible_Languages => No_Name_List,
Compiler_Driver => No_File, Compiler_Driver => No_File,
Compiler_Driver_Path => null, Compiler_Driver_Path => null,
Compiler_Leading_Required_Switches => No_Name_List, Compiler_Leading_Required_Switches
Compiler_Trailing_Required_Switches => No_Name_List, => No_Name_List,
Compiler_Trailing_Required_Switches
=> No_Name_List,
Multi_Unit_Switches => No_Name_List, Multi_Unit_Switches => No_Name_List,
Multi_Unit_Object_Separator => ' ', Multi_Unit_Object_Separator => ' ',
Path_Syntax => Canonical, Path_Syntax => Canonical,

2
gcc/ada/sem_attr.adb
View File

@ -3860,7 +3860,7 @@ package body Sem_Attr is
end if; end if;
end Check_Local; 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 -- an entity in the enclosing subprogram. If it is a component of a
-- formal its expansion might generate actual subtypes that may be -- formal its expansion might generate actual subtypes that may be
-- referenced in an inner context, and which must be elaborated -- referenced in an inner context, and which must be elaborated

44
gcc/ada/sem_ch12.adb
View File

@ -519,19 +519,11 @@ package body Sem_Ch12 is
procedure Insert_Freeze_Node_For_Instance procedure Insert_Freeze_Node_For_Instance
(N : Node_Id; (N : Node_Id;
F_Node : Node_Id); F_Node : Node_Id);
-- N is an instance and F_Node is its corresponding freeze node. Insert -- N denotes a package or a subprogram instantiation and F_Node is the
-- F_Node depending on the enclosing context and placement of N in the -- associated freeze node. Insert the freeze node before the first source
-- following manner: -- 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
-- 1) N is a package instance - Attempt to insert the freeze node before -- contains N.
-- 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.
procedure Freeze_Subprogram_Body procedure Freeze_Subprogram_Body
(Inst_Node : Node_Id; (Inst_Node : Node_Id;
@ -7586,7 +7578,6 @@ package body Sem_Ch12 is
elsif Nkind (Parent (N)) = N_Package_Body elsif Nkind (Parent (N)) = N_Package_Body
and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N)) and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
then then
declare declare
Enclosing : constant Entity_Id := Enclosing : constant Entity_Id :=
Corresponding_Spec (Parent (N)); Corresponding_Spec (Parent (N));
@ -7596,7 +7587,30 @@ package body Sem_Ch12 is
Ensure_Freeze_Node (Enclosing); Ensure_Freeze_Node (Enclosing);
if not Is_List_Member (Freeze_Node (Enclosing)) then 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 if;
end; end;

72
gcc/ada/sem_ch4.adb
View File

@ -276,11 +276,16 @@ package body Sem_Ch4 is
-- subprogram, and the call F (X) interpreted as F.all (X). In this case -- subprogram, and the call F (X) interpreted as F.all (X). In this case
-- the call may be overloaded with both interpretations. -- 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 -- 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 -- 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 -- 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); procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo); pragma Warnings (Off, wpo);
@ -4165,6 +4170,25 @@ package body Sem_Ch4 is
then then
return; return;
end if; 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; end if;
if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then 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 -- -- 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)); K : constant Node_Kind := Nkind (Parent (N));
Is_Subprg_Call : constant Boolean := Nkind_In Is_Subprg_Call : constant Boolean := Nkind_In
(K, N_Procedure_Call_Statement, (K, N_Procedure_Call_Statement,
@ -6898,14 +6924,17 @@ package body Sem_Ch4 is
---------------------- ----------------------
procedure Report_Ambiguity (Op : Entity_Id) is procedure Report_Ambiguity (Op : Entity_Id) is
Access_Formal : constant Boolean :=
Is_Access_Type (Etype (First_Formal (Op)));
Access_Actual : constant Boolean := Access_Actual : constant Boolean :=
Is_Access_Type (Etype (Prefix (N))); Is_Access_Type (Etype (Prefix (N)));
Access_Formal : Boolean := False;
begin begin
Error_Msg_Sloc := Sloc (Op); 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 Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N Error_Msg_N
@ -7205,6 +7234,13 @@ package body Sem_Ch4 is
-- Start of processing for Try_Class_Wide_Operation -- Start of processing for Try_Class_Wide_Operation
begin 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 -- Loop through ancestor types (including interfaces), traversing
-- the homonym chain of the subprogram, trying out those homonyms -- the homonym chain of the subprogram, trying out those homonyms
-- whose first formal has the class-wide type of the ancestor, or -- 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); pragma Unreferenced (CW_Result);
begin begin
Prim_Result := if not CW_Test_Only then
Try_Primitive_Operation Prim_Result :=
(Call_Node => New_Call_Node, Try_Primitive_Operation
Node_To_Replace => Node_To_Replace); (Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace);
end if;
-- Check if there is a class-wide subprogram covering the -- Check if there is a class-wide subprogram covering the
-- primitive. This check must be done even if a candidate -- primitive. This check must be done even if a candidate
@ -7663,10 +7701,18 @@ package body Sem_Ch4 is
end if; end if;
if Etype (New_Call_Node) /= Any_Type then if Etype (New_Call_Node) /= Any_Type then
Complete_Object_Operation
(Call_Node => New_Call_Node, -- No need to complete the tree transformations if we are only
Node_To_Replace => Node_To_Replace); -- searching for conflicting class-wide subprograms
return True;
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 elsif Present (Candidate) then