sem_ch3.ads, [...] (Build_Discriminal): Add link to original discriminant.
2005-11-14 Ed Schonberg <schonberg@adacore.com> Javier Miranda <miranda@adacore.com> * sem_ch3.ads, sem_ch3.adb (Build_Discriminal): Add link to original discriminant. (Build_Private_Derived_Type): The entity of the created full view of the derived type does not come from source. If after installing the private declarations of the parent scope the parent is still private, use its full view to construct the full declaration of the derived type. (Build_Derived_Record_Type): Relax the condition that controls the execution of the check that verifies that the partial view and the full view agree in the set of implemented interfaces. In addition, this test now only takes into account the progenitors. (Derive_Interface_Subprograms): No need to derive subprograms of ancestors that are interfaces. (Derive_Subprograms): Remove formal No_Predefined_Prims and the associated code. Change name Is_Package to Is_Package_Or_Generic_Package (Complete_Subprograms_Derivation): Handle the case in which the full view is a transitive derivation of the ancestor of the partial view. (Process_Full_View): Rename local subprogram Find_Interface_In_ Descendant to Find_Ancestor_Interface to leave the code more clear. Remove wrong code that avoids the generation of an error message when the immediate ancestor of the partial view is an interface. In addition some minor reorganization of the code has been done to leave it more clear. (Analyze_Type_Declaration): If type has previous incomplete tagged partial view, inherit properly its primitive operations. (Collect_Interfaces): Make public, for analysis of formal interfaces. (Analyze_Interface_Declaration): New procedure for use for regular and formal interface declarations. (Build_Derived_Record_Type): Add support for private types to the code that checks if a tagged type implements abstract interfaces. (Check_Aliased_Component_Type): The test applies in the spec of an instance as well. (Access_Type_Declaration): Clean up declaration of malformed type declared as an access to its own classwide type, to prevent cascaded crash. (Collect_Interfaces): For private extensions and for derived task types and derived protected types, the parent may be an interface that must be included in the interface list. (Access_Definition): If the designated type is an interface that may contain tasks, create Master_Id for it before analyzing the expression of the declaration, which may be an allocator. (Record_Type_Declaration): Set properly the interface kind, for use in allocators, the creation of master id's for task interfaces, etc. From-SVN: r107000
This commit is contained in:
parent
04814daddf
commit
950d3e7dae
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2005, 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- --
|
||||
|
@ -171,14 +171,6 @@ package body Sem_Ch3 is
|
|||
-- False is for an implicit derived full type for a type derived from a
|
||||
-- private type (see Build_Derived_Type).
|
||||
|
||||
procedure Collect_Interfaces
|
||||
(N : Node_Id;
|
||||
Derived_Type : Entity_Id);
|
||||
-- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type.
|
||||
-- Collect the list of interfaces that are not already implemented by the
|
||||
-- ancestors. This is the list of interfaces for which we must provide
|
||||
-- additional tag components.
|
||||
|
||||
procedure Complete_Subprograms_Derivation
|
||||
(Partial_View : Entity_Id;
|
||||
Derived_Type : Entity_Id);
|
||||
|
@ -799,6 +791,20 @@ package body Sem_Ch3 is
|
|||
Set_Has_Delayed_Freeze (Current_Scope);
|
||||
end if;
|
||||
|
||||
-- Ada 2005: if the designated type is an interface that may contain
|
||||
-- tasks, create a Master entity for the declaration. This must be done
|
||||
-- before expansion of the full declaration, because the declaration
|
||||
-- may include an expression that is an allocator, whose expansion needs
|
||||
-- the proper Master for the created tasks.
|
||||
|
||||
if Nkind (Related_Nod) = N_Object_Declaration
|
||||
and then Expander_Active
|
||||
and then Is_Interface (Desig_Type)
|
||||
and then Is_Limited_Record (Desig_Type)
|
||||
then
|
||||
Build_Class_Wide_Master (Anon_Type);
|
||||
end if;
|
||||
|
||||
return Anon_Type;
|
||||
end Access_Definition;
|
||||
|
||||
|
@ -985,6 +991,10 @@ package body Sem_Ch3 is
|
|||
then
|
||||
Error_Msg_N
|
||||
("access type cannot designate its own classwide type", S);
|
||||
|
||||
-- Clean up indication of tagged status to prevent cascaded errors
|
||||
|
||||
Set_Is_Tagged_Type (T, False);
|
||||
end if;
|
||||
|
||||
Set_Etype (T, T);
|
||||
|
@ -1584,6 +1594,33 @@ package body Sem_Ch3 is
|
|||
Set_Is_Pure (T, F);
|
||||
end Analyze_Incomplete_Type_Decl;
|
||||
|
||||
-----------------------------------
|
||||
-- Analyze_Interface_Declaration --
|
||||
-----------------------------------
|
||||
|
||||
procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is
|
||||
begin
|
||||
Set_Is_Tagged_Type (T);
|
||||
|
||||
Set_Is_Limited_Record (T, Limited_Present (Def)
|
||||
or else Task_Present (Def)
|
||||
or else Protected_Present (Def)
|
||||
or else Synchronized_Present (Def));
|
||||
|
||||
-- Type is abstract if full declaration carries keyword, or if
|
||||
-- previous partial view did.
|
||||
|
||||
Set_Is_Abstract (T);
|
||||
Set_Is_Interface (T);
|
||||
|
||||
Set_Is_Limited_Interface (T, Limited_Present (Def));
|
||||
Set_Is_Protected_Interface (T, Protected_Present (Def));
|
||||
Set_Is_Synchronized_Interface (T, Synchronized_Present (Def));
|
||||
Set_Is_Task_Interface (T, Task_Present (Def));
|
||||
Set_Abstract_Interfaces (T, New_Elmt_List);
|
||||
Set_Primitive_Operations (T, New_Elmt_List);
|
||||
end Analyze_Interface_Declaration;
|
||||
|
||||
-----------------------------
|
||||
-- Analyze_Itype_Reference --
|
||||
-----------------------------
|
||||
|
@ -1958,7 +1995,7 @@ package body Sem_Ch3 is
|
|||
if Constant_Present (N)
|
||||
and then No (E)
|
||||
then
|
||||
if not Is_Package (Current_Scope) then
|
||||
if not Is_Package_Or_Generic_Package (Current_Scope) then
|
||||
Error_Msg_N
|
||||
("invalid context for deferred constant declaration ('R'M 7.4)",
|
||||
N);
|
||||
|
@ -2589,7 +2626,7 @@ package body Sem_Ch3 is
|
|||
return;
|
||||
end if;
|
||||
|
||||
if (not Is_Package (Current_Scope)
|
||||
if (not Is_Package_Or_Generic_Package (Current_Scope)
|
||||
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
|
||||
or else In_Private_Part (Current_Scope)
|
||||
|
||||
|
@ -3011,6 +3048,51 @@ package body Sem_Ch3 is
|
|||
or else
|
||||
In_Package_Body (Current_Scope));
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type;
|
||||
-- If there is a tagged incomplete partial view of the type, transfer
|
||||
-- its operations to the full view, and indicate that the type of the
|
||||
-- controlling parameter (s) is this full view.
|
||||
|
||||
------------------------------------
|
||||
-- Check_Ops_From_Incomplete_Type --
|
||||
------------------------------------
|
||||
|
||||
procedure Check_Ops_From_Incomplete_Type is
|
||||
Elmt : Elmt_Id;
|
||||
Formal : Entity_Id;
|
||||
Op : Entity_Id;
|
||||
|
||||
begin
|
||||
if Prev /= T
|
||||
and then Ekind (Prev) = E_Incomplete_Type
|
||||
and then Is_Tagged_Type (Prev)
|
||||
and then Is_Tagged_Type (T)
|
||||
then
|
||||
Elmt := First_Elmt (Primitive_Operations (Prev));
|
||||
while Present (Elmt) loop
|
||||
Op := Node (Elmt);
|
||||
Prepend_Elmt (Op, Primitive_Operations (T));
|
||||
|
||||
Formal := First_Formal (Op);
|
||||
while Present (Formal) loop
|
||||
if Etype (Formal) = Prev then
|
||||
Set_Etype (Formal, T);
|
||||
end if;
|
||||
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
|
||||
if Etype (Op) = Prev then
|
||||
Set_Etype (Op, T);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
end if;
|
||||
end Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Start of processing for Analyze_Type_Declaration
|
||||
|
||||
begin
|
||||
Prev := Find_Type_Name (N);
|
||||
|
||||
|
@ -3149,6 +3231,7 @@ package body Sem_Ch3 is
|
|||
-- Some common processing for all types
|
||||
|
||||
Set_Depends_On_Private (T, Has_Private_Component (T));
|
||||
Check_Ops_From_Incomplete_Type;
|
||||
|
||||
-- Both the declared entity, and its anonymous base type if one
|
||||
-- was created, need freeze nodes allocated.
|
||||
|
@ -3787,7 +3870,8 @@ package body Sem_Ch3 is
|
|||
if Number_Dimensions (Parent_Type) = 1
|
||||
and then not Is_Limited_Type (Parent_Type)
|
||||
and then not Is_Derived_Type (Parent_Type)
|
||||
and then not Is_Package (Scope (Base_Type (Parent_Type)))
|
||||
and then not Is_Package_Or_Generic_Package
|
||||
(Scope (Base_Type (Parent_Type)))
|
||||
then
|
||||
if not Is_Constrained (Parent_Type)
|
||||
and then Is_Constrained (Derived_Type)
|
||||
|
@ -4438,6 +4522,7 @@ package body Sem_Ch3 is
|
|||
Full_Decl := New_Copy_Tree (N);
|
||||
Full_Der := New_Copy (Derived_Type);
|
||||
Set_Comes_From_Source (Full_Decl, False);
|
||||
Set_Comes_From_Source (Full_Der, False);
|
||||
|
||||
Insert_After (N, Full_Decl);
|
||||
|
||||
|
@ -4493,8 +4578,18 @@ package body Sem_Ch3 is
|
|||
-- view, the completion does not derive them anew.
|
||||
|
||||
if not Is_Tagged_Type (Parent_Type) then
|
||||
Build_Derived_Record_Type
|
||||
(Full_Decl, Parent_Type, Full_Der, False);
|
||||
|
||||
-- If the parent is itself derived from another private type,
|
||||
-- installing the private declarations has not affected its
|
||||
-- privacy status, so use its own full view explicitly.
|
||||
|
||||
if Is_Private_Type (Parent_Type) then
|
||||
Build_Derived_Record_Type
|
||||
(Full_Decl, Full_View (Parent_Type), Full_Der, False);
|
||||
else
|
||||
Build_Derived_Record_Type
|
||||
(Full_Decl, Parent_Type, Full_Der, False);
|
||||
end if;
|
||||
|
||||
else
|
||||
-- If full view of parent is tagged, the completion
|
||||
|
@ -5895,113 +5990,37 @@ package body Sem_Ch3 is
|
|||
Collect_Interfaces (Type_Definition (N), Derived_Type);
|
||||
end if;
|
||||
|
||||
-- Check that the full view and the partial view agree
|
||||
-- in the set of implemented interfaces
|
||||
-- Ada 2005 (AI-251): The progenitor types specified in a private
|
||||
-- extension declaration and the progenitor types specified in the
|
||||
-- corresponding declaration of a record extension given in the
|
||||
-- private part need not be the same; the only requirement is that
|
||||
-- the private extension must be descended from each interface
|
||||
-- from which the record extension is descended (AARM 7.3, 20.1/2)
|
||||
|
||||
if Has_Private_Declaration (Derived_Type)
|
||||
and then Present (Abstract_Interfaces (Derived_Type))
|
||||
and then not Is_Empty_Elmt_List
|
||||
(Abstract_Interfaces (Derived_Type))
|
||||
then
|
||||
if Has_Private_Declaration (Derived_Type) then
|
||||
declare
|
||||
N_Partial : constant Node_Id := Parent (Tagged_Partial_View);
|
||||
N_Full : constant Node_Id := Parent (Derived_Type);
|
||||
|
||||
Iface_Partial : Entity_Id;
|
||||
Iface_Full : Entity_Id;
|
||||
Num_Ifaces_Partial : Natural := 0;
|
||||
Num_Ifaces_Full : Natural := 0;
|
||||
Same_Interfaces : Boolean := True;
|
||||
Iface_Partial : Entity_Id;
|
||||
|
||||
begin
|
||||
if Nkind (N_Partial) /= N_Private_Extension_Declaration then
|
||||
Error_Msg_N
|
||||
("(Ada 2005) interfaces only allowed in private"
|
||||
& " extension declarations", N_Partial);
|
||||
end if;
|
||||
|
||||
-- Count the interfaces implemented by the partial view
|
||||
|
||||
if Nkind (N_Partial) = N_Private_Extension_Declaration
|
||||
and then not Is_Empty_List (Interface_List (N_Partial))
|
||||
then
|
||||
Iface_Partial := First (Interface_List (N_Partial));
|
||||
|
||||
while Present (Iface_Partial) loop
|
||||
Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
|
||||
Next (Iface_Partial);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Take into account the case in which the partial
|
||||
-- view is a directly derived from an interface
|
||||
|
||||
if Is_Interface (Etype
|
||||
(Defining_Identifier (N_Partial)))
|
||||
then
|
||||
Num_Ifaces_Partial := Num_Ifaces_Partial + 1;
|
||||
end if;
|
||||
|
||||
-- Count the interfaces implemented by the full view
|
||||
|
||||
if not Is_Empty_List (Interface_List
|
||||
(Type_Definition (N_Full)))
|
||||
then
|
||||
Iface_Full := First (Interface_List
|
||||
(Type_Definition (N_Full)));
|
||||
while Present (Iface_Full) loop
|
||||
Num_Ifaces_Full := Num_Ifaces_Full + 1;
|
||||
Next (Iface_Full);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Take into account the case in which the full
|
||||
-- view is a directly derived from an interface
|
||||
|
||||
if Is_Interface (Etype
|
||||
(Defining_Identifier (N_Full)))
|
||||
then
|
||||
Num_Ifaces_Full := Num_Ifaces_Full + 1;
|
||||
end if;
|
||||
|
||||
if Num_Ifaces_Full > 0
|
||||
and then Num_Ifaces_Full = Num_Ifaces_Partial
|
||||
then
|
||||
-- Check that the full-view and the private-view have
|
||||
-- the same list of interfaces.
|
||||
|
||||
Iface_Full := First (Interface_List
|
||||
(Type_Definition (N_Full)));
|
||||
while Present (Iface_Full) loop
|
||||
Iface_Partial := First (Interface_List (N_Partial));
|
||||
while Present (Iface_Partial)
|
||||
and then Etype (Iface_Partial) /= Etype (Iface_Full)
|
||||
loop
|
||||
Next (Iface_Partial);
|
||||
end loop;
|
||||
|
||||
-- If not found we check if the partial view is a
|
||||
-- direct derivation of the interface.
|
||||
|
||||
if not Present (Iface_Partial)
|
||||
and then
|
||||
Etype (Tagged_Partial_View) /= Etype (Iface_Full)
|
||||
if not Interface_Present_In_Ancestor
|
||||
(Derived_Type, Etype (Iface_Partial))
|
||||
then
|
||||
Same_Interfaces := False;
|
||||
Error_Msg_N
|
||||
("(Ada 2005) full type and private extension must"
|
||||
& " have the same progenitors", Derived_Type);
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next (Iface_Full);
|
||||
Next (Iface_Partial);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
if Num_Ifaces_Partial /= Num_Ifaces_Full
|
||||
or else not Same_Interfaces
|
||||
then
|
||||
Error_Msg_N
|
||||
("(Ada 2005) full declaration and private declaration"
|
||||
& " must have the same list of interfaces",
|
||||
Derived_Type);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
@ -6132,7 +6151,14 @@ package body Sem_Ch3 is
|
|||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
E := Derived_Type;
|
||||
-- Handle private types
|
||||
|
||||
if Present (Full_View (Derived_Type)) then
|
||||
E := Full_View (Derived_Type);
|
||||
else
|
||||
E := Derived_Type;
|
||||
end if;
|
||||
|
||||
loop
|
||||
if Is_Interface (E)
|
||||
or else (Present (Abstract_Interfaces (E))
|
||||
|
@ -6145,11 +6171,22 @@ package body Sem_Ch3 is
|
|||
|
||||
exit when Etype (E) = E
|
||||
|
||||
-- Handle private types
|
||||
|
||||
or else (Present (Full_View (Etype (E)))
|
||||
and then Full_View (Etype (E)) = E)
|
||||
|
||||
-- Protect the frontend against wrong source
|
||||
|
||||
or else Etype (E) = Derived_Type;
|
||||
|
||||
E := Etype (E);
|
||||
-- Climb to the ancestor type handling private types
|
||||
|
||||
if Present (Full_View (Etype (E))) then
|
||||
E := Full_View (Etype (E));
|
||||
else
|
||||
E := Etype (E);
|
||||
end if;
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
@ -6168,7 +6205,7 @@ package body Sem_Ch3 is
|
|||
|
||||
if Present (Tagged_Partial_View) then
|
||||
Derive_Subprograms
|
||||
(Parent_Type, Derived_Type, Predefined_Prims_Only => True);
|
||||
(Parent_Type, Derived_Type);
|
||||
|
||||
Complete_Subprograms_Derivation
|
||||
(Partial_View => Tagged_Partial_View,
|
||||
|
@ -6452,10 +6489,11 @@ package body Sem_Ch3 is
|
|||
then
|
||||
CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim));
|
||||
|
||||
Set_Ekind (CR_Disc, E_In_Parameter);
|
||||
Set_Mechanism (CR_Disc, Default_Mechanism);
|
||||
Set_Etype (CR_Disc, Etype (Discrim));
|
||||
Set_CR_Discriminant (Discrim, CR_Disc);
|
||||
Set_Ekind (CR_Disc, E_In_Parameter);
|
||||
Set_Mechanism (CR_Disc, Default_Mechanism);
|
||||
Set_Etype (CR_Disc, Etype (Discrim));
|
||||
Set_Discriminal_Link (CR_Disc, Discrim);
|
||||
Set_CR_Discriminant (Discrim, CR_Disc);
|
||||
end if;
|
||||
end Build_Discriminal;
|
||||
|
||||
|
@ -7179,7 +7217,7 @@ package body Sem_Ch3 is
|
|||
if Is_Aliased (C)
|
||||
and then Has_Discriminants (Etype (C))
|
||||
and then not Is_Constrained (Etype (C))
|
||||
and then not In_Instance
|
||||
and then not In_Instance_Body
|
||||
and then Ada_Version < Ada_05
|
||||
then
|
||||
Error_Msg_N
|
||||
|
@ -7194,7 +7232,8 @@ package body Sem_Ch3 is
|
|||
if Has_Aliased_Components (T)
|
||||
and then Has_Discriminants (Component_Type (T))
|
||||
and then not Is_Constrained (Component_Type (T))
|
||||
and then not In_Instance
|
||||
and then not In_Instance_Body
|
||||
and then Ada_Version < Ada_05
|
||||
then
|
||||
Error_Msg_N
|
||||
("aliased component type must be constrained ('R'M 3.6(11))",
|
||||
|
@ -7363,7 +7402,7 @@ package body Sem_Ch3 is
|
|||
Post_Error;
|
||||
end if;
|
||||
|
||||
elsif Is_Package (E) then
|
||||
elsif Is_Package_Or_Generic_Package (E) then
|
||||
if Unit_Requires_Body (E) then
|
||||
if not Has_Completion (E)
|
||||
and then Nkind (Parent (Unit_Declaration_Node (E))) /=
|
||||
|
@ -7643,6 +7682,29 @@ package body Sem_Ch3 is
|
|||
|
||||
Next (Intf);
|
||||
end loop;
|
||||
|
||||
-- A type extension may be written as a derivation from an interface.
|
||||
-- The completion will have to implement the same, or derive from a
|
||||
-- type that implements it as well.
|
||||
|
||||
elsif Nkind (N) = N_Private_Extension_Declaration
|
||||
and then Is_Interface (Etype (Derived_Type))
|
||||
then
|
||||
Add_Interface (Etype (Derived_Type));
|
||||
end if;
|
||||
|
||||
-- Same for task and protected types, that can derive directly from
|
||||
-- an interface (and implement additional interfaces that will be
|
||||
-- present in the interface list of the declaration).
|
||||
|
||||
if Nkind (N) = N_Task_Type_Declaration
|
||||
or else Nkind (N) = N_Protected_Type_Declaration
|
||||
or else Nkind (N) = N_Single_Protected_Declaration
|
||||
or else Nkind (N) = N_Single_Task_Declaration
|
||||
then
|
||||
if Is_Interface (Etype (Derived_Type)) then
|
||||
Add_Interface (Etype (Derived_Type));
|
||||
end if;
|
||||
end if;
|
||||
end Collect_Interfaces;
|
||||
|
||||
|
@ -7873,6 +7935,25 @@ package body Sem_Ch3 is
|
|||
E : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Handle the case in which the full-view is a transitive
|
||||
-- derivation of the ancestor of the partial view.
|
||||
|
||||
-- type I is interface;
|
||||
-- type T is new I with ...
|
||||
|
||||
-- package H is
|
||||
-- type DT is new I with private;
|
||||
-- private
|
||||
-- type DT is new T with ...
|
||||
-- end;
|
||||
|
||||
if Etype (Partial_View) /= Etype (Derived_Type)
|
||||
and then Is_Interface (Etype (Partial_View))
|
||||
and then Is_Ancestor (Etype (Partial_View), Etype (Derived_Type))
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Tagged_Type (Partial_View) then
|
||||
Elmt_P := First_Elmt (Primitive_Operations (Partial_View));
|
||||
else
|
||||
|
@ -8795,7 +8876,7 @@ package body Sem_Ch3 is
|
|||
|
||||
-- For concurrent types, the associated record value type carries the same
|
||||
-- discriminants, so when we constrain a concurrent type, we must constrain
|
||||
-- the value type as well.
|
||||
-- the corresponding record type as well.
|
||||
|
||||
procedure Constrain_Concurrent
|
||||
(Def_Id : in out Entity_Id;
|
||||
|
@ -9970,10 +10051,12 @@ package body Sem_Ch3 is
|
|||
then
|
||||
AI := First_Elmt (Abstract_Interfaces (T));
|
||||
while Present (AI) loop
|
||||
Derive_Subprograms
|
||||
(Parent_Type => Node (AI),
|
||||
Derived_Type => Derived_Type,
|
||||
No_Predefined_Prims => True);
|
||||
if not Is_Ancestor (Node (AI), Derived_Type) then
|
||||
Derive_Subprograms
|
||||
(Parent_Type => Node (AI),
|
||||
Derived_Type => Derived_Type,
|
||||
No_Predefined_Prims => True);
|
||||
end if;
|
||||
|
||||
Next_Elmt (AI);
|
||||
end loop;
|
||||
|
@ -10391,8 +10474,7 @@ package body Sem_Ch3 is
|
|||
(Parent_Type : Entity_Id;
|
||||
Derived_Type : Entity_Id;
|
||||
Generic_Actual : Entity_Id := Empty;
|
||||
No_Predefined_Prims : Boolean := False;
|
||||
Predefined_Prims_Only : Boolean := False)
|
||||
No_Predefined_Prims : Boolean := False)
|
||||
is
|
||||
Op_List : constant Elist_Id :=
|
||||
Collect_Primitive_Operations (Parent_Type);
|
||||
|
@ -10436,7 +10518,13 @@ package body Sem_Ch3 is
|
|||
if No_Predefined_Prims and then Is_Predef then
|
||||
null;
|
||||
|
||||
elsif Predefined_Prims_Only and then not Is_Predef then
|
||||
-- We don't need to derive alias entities associated with
|
||||
-- abstract interfaces
|
||||
|
||||
elsif Is_Dispatching_Operation (Subp)
|
||||
and then Present (Alias (Subp))
|
||||
and then Present (Abstract_Interface_Alias (Subp))
|
||||
then
|
||||
null;
|
||||
|
||||
elsif No (Generic_Actual) then
|
||||
|
@ -13098,15 +13186,15 @@ package body Sem_Ch3 is
|
|||
Full_Parent : Entity_Id;
|
||||
Full_Indic : Node_Id;
|
||||
|
||||
function Find_Interface_In_Descendant
|
||||
function Find_Ancestor_Interface
|
||||
(Typ : Entity_Id) return Entity_Id;
|
||||
-- Find an implemented interface in the derivation chain of Typ
|
||||
|
||||
----------------------------------
|
||||
-- Find_Interface_In_Descendant --
|
||||
----------------------------------
|
||||
-----------------------------
|
||||
-- Find_Ancestor_Interface --
|
||||
-----------------------------
|
||||
|
||||
function Find_Interface_In_Descendant
|
||||
function Find_Ancestor_Interface
|
||||
(Typ : Entity_Id) return Entity_Id
|
||||
is
|
||||
T : Entity_Id;
|
||||
|
@ -13127,7 +13215,7 @@ package body Sem_Ch3 is
|
|||
end loop;
|
||||
|
||||
return Empty;
|
||||
end Find_Interface_In_Descendant;
|
||||
end Find_Ancestor_Interface;
|
||||
|
||||
-- Start of processing for Process_Full_View
|
||||
|
||||
|
@ -13180,37 +13268,36 @@ package body Sem_Ch3 is
|
|||
Iface_Def : Node_Id;
|
||||
|
||||
begin
|
||||
Iface := Find_Interface_In_Descendant (Full_T);
|
||||
Iface := Find_Ancestor_Interface (Full_T);
|
||||
|
||||
if Present (Iface) then
|
||||
Iface_Def := Type_Definition (Parent (Iface));
|
||||
end if;
|
||||
|
||||
-- The full view derives from an interface descendant, but the
|
||||
-- partial view does not share the same tagged type.
|
||||
-- The full view derives from an interface descendant, but the
|
||||
-- partial view does not share the same tagged type.
|
||||
|
||||
if Present (Iface)
|
||||
and then Is_Tagged_Type (Priv_T)
|
||||
and then Etype (Full_T) /= Etype (Priv_T)
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
|
||||
"completed by a type that implements an " &
|
||||
"interface", Priv_T);
|
||||
end if;
|
||||
if Is_Tagged_Type (Priv_T)
|
||||
and then Etype (Priv_T) /= Etype (Full_T)
|
||||
and then Etype (Priv_T) /= Iface
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) tagged partial view cannot be " &
|
||||
"completed by a type that implements an " &
|
||||
"interface", Priv_T);
|
||||
end if;
|
||||
|
||||
-- The full view derives from a limited, protected,
|
||||
-- synchronized or task interface descendant, but the
|
||||
-- partial view is not labeled as limited.
|
||||
-- The full view derives from a limited, protected,
|
||||
-- synchronized or task interface descendant, but the
|
||||
-- partial view is not labeled as limited.
|
||||
|
||||
if Present (Iface)
|
||||
and then (Limited_Present (Iface_Def)
|
||||
or Protected_Present (Iface_Def)
|
||||
or Synchronized_Present (Iface_Def)
|
||||
or Task_Present (Iface_Def))
|
||||
and then not Limited_Present (Parent (Priv_T))
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) non-limited private type cannot be " &
|
||||
"completed by a limited type", Priv_T);
|
||||
if (Limited_Present (Iface_Def)
|
||||
or else Protected_Present (Iface_Def)
|
||||
or else Synchronized_Present (Iface_Def)
|
||||
or else Task_Present (Iface_Def))
|
||||
and then not Limited_Present (Parent (Priv_T))
|
||||
then
|
||||
Error_Msg_N ("(Ada 2005) non-limited private type cannot be "
|
||||
& "completed by a limited type", Priv_T);
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
@ -13242,24 +13329,9 @@ package body Sem_Ch3 is
|
|||
return;
|
||||
|
||||
elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then
|
||||
|
||||
-- Ada 2005 (AI-251): No error needed if the immediate
|
||||
-- ancestor of the partial view is an interface
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- type PT1 is new I1 with private;
|
||||
-- private
|
||||
-- type PT1 is new T and I1 with null record;
|
||||
|
||||
if Is_Interface (Base_Type (Priv_Parent)) then
|
||||
null;
|
||||
|
||||
else
|
||||
Error_Msg_N
|
||||
("parent of full type must descend from parent"
|
||||
& " of private extension", Full_Indic);
|
||||
end if;
|
||||
Error_Msg_N
|
||||
("parent of full type must descend from parent"
|
||||
& " of private extension", Full_Indic);
|
||||
|
||||
-- Check the rules of 7.3(10): if the private extension inherits
|
||||
-- known discriminants, then the full type must also inherit those
|
||||
|
@ -14409,17 +14481,7 @@ package body Sem_Ch3 is
|
|||
|
||||
else
|
||||
Is_Tagged := True;
|
||||
Set_Is_Tagged_Type (T);
|
||||
|
||||
Set_Is_Limited_Record (T, Limited_Present (Def)
|
||||
or else Task_Present (Def)
|
||||
or else Protected_Present (Def));
|
||||
|
||||
-- Type is abstract if full declaration carries keyword, or if
|
||||
-- previous partial view did.
|
||||
|
||||
Set_Is_Abstract (T);
|
||||
Set_Is_Interface (T);
|
||||
Analyze_Interface_Declaration (T, Def);
|
||||
end if;
|
||||
|
||||
-- First pass: if there are self-referential access components,
|
||||
|
@ -14428,10 +14490,6 @@ package body Sem_Ch3 is
|
|||
|
||||
Check_Anonymous_Access_Types (Component_List (Def));
|
||||
|
||||
-- Ada 2005 (AI-251): Complete the initialization of attributes
|
||||
-- associated with abstract interfaces and decorate the names in the
|
||||
-- list of ancestor interfaces (if any).
|
||||
|
||||
if Ada_Version >= Ada_05
|
||||
and then Present (Interface_List (Def))
|
||||
then
|
||||
|
@ -14439,6 +14497,7 @@ package body Sem_Ch3 is
|
|||
Iface : Node_Id;
|
||||
Iface_Def : Node_Id;
|
||||
Iface_Typ : Entity_Id;
|
||||
|
||||
begin
|
||||
Iface := First (Interface_List (Def));
|
||||
while Present (Iface) loop
|
||||
|
@ -14521,9 +14580,8 @@ package body Sem_Ch3 is
|
|||
|
||||
Next (Iface);
|
||||
end loop;
|
||||
|
||||
Set_Abstract_Interfaces (T, New_Elmt_List);
|
||||
Collect_Interfaces (Type_Definition (N), T);
|
||||
Collect_Interfaces (Def, T);
|
||||
end;
|
||||
end if;
|
||||
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2005, 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- --
|
||||
|
@ -62,6 +62,9 @@ package Sem_Ch3 is
|
|||
-- Called to analyze a list of declarations (in what context ???). Also
|
||||
-- performs necessary freezing actions (more description needed ???)
|
||||
|
||||
procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id);
|
||||
-- Analyze an interface declaration or a formal interface declaration
|
||||
|
||||
procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id);
|
||||
-- Default and per object expressions do not freeze their components,
|
||||
-- and must be analyzed and resolved accordingly. The analysis is
|
||||
|
@ -97,6 +100,15 @@ package Sem_Ch3 is
|
|||
-- rather than on the declarations that require completion in the package
|
||||
-- declaration.
|
||||
|
||||
procedure Collect_Interfaces
|
||||
(N : Node_Id;
|
||||
Derived_Type : Entity_Id);
|
||||
-- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type
|
||||
-- and Analyze_Formal_Interface_Type.
|
||||
-- Collect the list of interfaces that are not already implemented by the
|
||||
-- ancestors. This is the list of interfaces for which we must provide
|
||||
-- additional tag components.
|
||||
|
||||
procedure Derive_Subprogram
|
||||
(New_Subp : in out Entity_Id;
|
||||
Parent_Subp : Entity_Id;
|
||||
|
@ -114,8 +126,7 @@ package Sem_Ch3 is
|
|||
(Parent_Type : Entity_Id;
|
||||
Derived_Type : Entity_Id;
|
||||
Generic_Actual : Entity_Id := Empty;
|
||||
No_Predefined_Prims : Boolean := False;
|
||||
Predefined_Prims_Only : Boolean := False);
|
||||
No_Predefined_Prims : Boolean := False);
|
||||
-- To complete type derivation, collect/retrieve the primitive operations
|
||||
-- of the parent type, and replace the subsidiary subtypes with the derived
|
||||
-- type, to build the specs of the inherited ops. For generic actuals, the
|
||||
|
@ -124,9 +135,7 @@ package Sem_Ch3 is
|
|||
-- the derived subprograms are aliased to those of the actual, not those of
|
||||
-- the ancestor. The last two params are used in case of derivation from
|
||||
-- abstract interface types: No_Predefined_Prims is used to avoid the
|
||||
-- derivation of predefined primitives from the interface, and Predefined
|
||||
-- Prims_Only is used to complete the derivation predefined primitives
|
||||
-- in case of private tagged types implementing interfaces.
|
||||
-- derivation of predefined primitives from an abstract interface.
|
||||
--
|
||||
-- Note: one might expect this to be private to the package body, but
|
||||
-- there is one rather unusual usage in package Exp_Dist.
|
||||
|
|
Loading…
Reference in New Issue