===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -50,14 +50,6 @@ package Exp_Ch9 is
-- Task_Id of the associated task as the parameter. The caller is
-- responsible for analyzing and resolving the resulting tree.
- function Build_Corresponding_Record
- (N : Node_Id;
- Ctyp : Node_Id;
- Loc : Source_Ptr) return Node_Id;
- -- Common to tasks and protected types. Copy discriminant specifications,
- -- build record declaration. N is the type declaration, Ctyp is the
- -- concurrent entity (task type or protected type).
-
function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
-- Create the statements which populate the entry names array of a task or
-- protected type. The statements are wrapped inside a block due to a local
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -128,6 +128,14 @@ package body Exp_Ch9 is
-- Build a specification for a function implementing the protected entry
-- barrier of the specified entry body.
+ function Build_Corresponding_Record
+ (N : Node_Id;
+ Ctyp : Node_Id;
+ Loc : Source_Ptr) return Node_Id;
+ -- Common to tasks and protected types. Copy discriminant specifications,
+ -- build record declaration. N is the type declaration, Ctyp is the
+ -- concurrent entity (task type or protected type).
+
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
@@ -1037,8 +1045,9 @@ package body Exp_Ch9 is
-- record is "limited tagged". It is "limited" to reflect the underlying
-- limitedness of the task or protected object that it represents, and
-- ensuring for example that it is properly passed by reference. It is
- -- "tagged" to give support to dispatching calls through interfaces (Ada
- -- 2005: AI-345)
+ -- "tagged" to give support to dispatching calls through interfaces. We
+ -- propagate here the list of interfaces covered by the concurrent type
+ -- (Ada 2005: AI-345).
return
Make_Full_Type_Declaration (Loc,
@@ -1051,6 +1060,7 @@ package body Exp_Ch9 is
Component_Items => Cdecls),
Tagged_Present =>
Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp),
+ Interface_List => Interface_List (N),
Limited_Present => True));
end Build_Corresponding_Record;
@@ -7682,11 +7692,6 @@ package body Exp_Ch9 is
Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
- -- Ada 2005 (AI-345): Propagate the attribute that contains the list
- -- of implemented interfaces.
-
- Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
Qualify_Entity_Names (N);
-- If the type has discriminants, their occurrences in the declaration
@@ -9946,11 +9951,6 @@ package body Exp_Ch9 is
Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
- -- Ada 2005 (AI-345): Propagate the attribute that contains the list
- -- of implemented interfaces.
-
- Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
Rec_Ent := Defining_Identifier (Rec_Decl);
Cdecls := Component_Items (Component_List
(Type_Definition (Rec_Decl)));
===================================================================
@@ -1176,16 +1176,6 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of protected type while inside a generic.
- -- The corresponding record is needed for various semantic checks.
-
- if Ada_Version >= Ada_05
- and then Inside_A_Generic
- then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (T)));
- end if;
-
Analyze (Protected_Definition (N));
-- Protected types with entries are controlled (because of the
@@ -1976,15 +1966,6 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of the task type while inside a generic
- -- context. The corresponding record is needed for various semantic
- -- checks.
-
- if Inside_A_Generic then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (T)));
- end if;
-
if Present (Task_Definition (N)) then
Analyze_Task_Definition (Task_Definition (N));
end if;
===================================================================
@@ -6880,23 +6880,26 @@ package body Sem_Ch4 is
-- Scan the list of generic formals to find subprograms
-- that may have a first controlling formal of the type.
- declare
- Decl : Node_Id;
-
- begin
- Decl :=
- First (Generic_Formal_Declarations
- (Unit_Declaration_Node (Scope (T))));
- while Present (Decl) loop
- if Nkind (Decl) in N_Formal_Subprogram_Declaration then
- Subp := Defining_Entity (Decl);
- Check_Candidate;
- end if;
-
- Next (Decl);
- end loop;
- end;
+ if Nkind (Unit_Declaration_Node (Scope (T)))
+ = N_Generic_Subprogram_Declaration
+ then
+ declare
+ Decl : Node_Id;
+ begin
+ Decl :=
+ First (Generic_Formal_Declarations
+ (Unit_Declaration_Node (Scope (T))));
+ while Present (Decl) loop
+ if Nkind (Decl) in N_Formal_Subprogram_Declaration then
+ Subp := Defining_Entity (Decl);
+ Check_Candidate;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end;
+ end if;
return Candidates;
else
@@ -6906,7 +6909,15 @@ package body Sem_Ch4 is
-- declaration or body (either the one that declares T, or a
-- child unit).
- Subp := First_Entity (Scope (T));
+ -- For a subtype representing a generic actual type, go to the
+ -- base type.
+
+ if Is_Generic_Actual_Type (T) then
+ Subp := First_Entity (Scope (Base_Type (T)));
+ else
+ Subp := First_Entity (Scope (T));
+ end if;
+
while Present (Subp) loop
if Is_Overloadable (Subp) then
Check_Candidate;
@@ -6979,13 +6990,14 @@ package body Sem_Ch4 is
-- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then
- if not Present (Corresponding_Record_Type (Obj_Type)) then
- return False;
+ if Present (Corresponding_Record_Type (Obj_Type)) then
+ Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
+ Elmt := First_Elmt (Primitive_Operations (Corr_Type));
+ else
+ Corr_Type := Obj_Type;
+ Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
end if;
- Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
- Elmt := First_Elmt (Primitive_Operations (Corr_Type));
-
elsif not Is_Generic_Type (Obj_Type) then
Corr_Type := Obj_Type;
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
===================================================================
@@ -677,18 +677,15 @@ package body Sem_Disp is
Set_Is_Dispatching_Operation (Subp, False);
Tagged_Type := Find_Dispatching_Type (Subp);
- -- Ada 2005 (AI-345)
+ -- Ada 2005 (AI-345): Use the corresponding record (if available).
+ -- Required because primitives of concurrent types are be attached
+ -- to the corresponding record (not to the concurrent type).
if Ada_Version >= Ada_05
and then Present (Tagged_Type)
and then Is_Concurrent_Type (Tagged_Type)
+ and then Present (Corresponding_Record_Type (Tagged_Type))
then
- -- Protect the frontend against previously detected errors
-
- if No (Corresponding_Record_Type (Tagged_Type)) then
- return;
- end if;
-
Tagged_Type := Corresponding_Record_Type (Tagged_Type);
end if;
@@ -1068,6 +1065,18 @@ package body Sem_Disp is
end if;
end if;
+ -- If the tagged type is a concurrent type then we must be compiling
+ -- with no code generation (we are either compiling a generic unit or
+ -- compiling under -gnatc mode) because we have previously tested that
+ -- no serious errors has been reported. In this case we do not add the
+ -- primitive to the list of primitives of Tagged_Type but we leave the
+ -- primitive decorated as a dispatching operation to be able to analyze
+ -- and report errors associated with the Object.Operation notation.
+
+ elsif Is_Concurrent_Type (Tagged_Type) then
+ pragma Assert (not Expander_Active);
+ null;
+
-- If no old subprogram, then we add this as a dispatching operation,
-- but we avoid doing this if an error was posted, to prevent annoying
-- cascaded errors.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -46,7 +46,12 @@ package Sem_Disp is
-- if it has a parameter of this type and is defined at a proper place for
-- primitive operations (new primitives are only defined in package spec,
-- overridden operation can be defined in any scope). If Old_Subp is not
- -- Empty we are in the overriding case.
+ -- Empty we are in the overriding case. If the tagged type associated with
+ -- Subp is a concurrent type (case that occurs when the type is declared in
+ -- a generic because the analysis of generics disables generation of the
+ -- corresponding record) then this routine does does not add "Subp" to the
+ -- list of primitive operations but leaves Subp decorated as dispatching
+ -- operation to enable checks associated with the Object.Operation notation
procedure Check_Operation_From_Incomplete_Type
(Subp : Entity_Id;