Skip to content

R
riscv-gcc-1
Commit cec29135 by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch3.adb (Access_Subprogram_Definition): Additional checks on illegal uses of… 

sem_ch3.adb (Access_Subprogram_Definition): Additional checks on illegal uses of incomplete types in formal parts and...

2009-04-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Access_Subprogram_Definition): Additional checks on
	illegal uses of incomplete types in formal parts and return types.

	* sem_ch6.adb (Process_Formals): Taft-amendment types are legal in
	access to subprograms.

	* sem_ch7.adb (Uninstall_Declarations): diagnose attempts to use
	Taft-amendment types as the return type of an access_to_function type.

	* freeze.adb (Freeze_Entity): Remove tests on formals of an incomplete
	type for access_to_subprograms. The check is performed on package exit.

From-SVN: r146229
parent 618fb570
Showing with 199 additions and 203 deletions
gcc/ada/freeze.adb
...@@ -3497,50 +3497,11 @@ package body Freeze is ...@@ -3497,50 +3497,11 @@ package body Freeze is
Freeze_Subprogram (E); Freeze_Subprogram (E);
-- Ada 2005 (AI-326): Check wrong use of tag incomplete type
-- type T; -- tagged or untagged, may be from limited view
-- type Acc is access function (X : T) return T; -- ERROR
if Ekind (Etype (E)) = E_Incomplete_Type
and then No (Full_View (Etype (E)))
and then not Is_Value_Type (Etype (E))
then
Error_Msg_NE
("invalid use of incomplete type&", E, Etype (E));
end if;
-- For access to a protected subprogram, freeze the equivalent type -- For access to a protected subprogram, freeze the equivalent type
-- (however this is not set if we are not generating code or if this -- (however this is not set if we are not generating code or if this
-- is an anonymous type used just for resolution). -- is an anonymous type used just for resolution).
elsif Is_Access_Protected_Subprogram_Type (E) then elsif Is_Access_Protected_Subprogram_Type (E) then
-- AI-326: Check wrong use of tagged incomplete types
-- type T is tagged;
-- type As3D is access protected
-- function (X : Float) return T; -- ERROR
declare
Etyp : Entity_Id;
begin
Etyp := Etype (Directly_Designated_Type (E));
if Is_Class_Wide_Type (Etyp) then
Etyp := Etype (Etyp);
end if;
if Ekind (Etyp) = E_Incomplete_Type
and then No (Full_View (Etyp))
and then not Is_Value_Type (Etype (E))
then
Error_Msg_NE
("invalid use of incomplete type&", E, Etyp);
end if;
end;
if Present (Equivalent_Type (E)) then if Present (Equivalent_Type (E)) then
Freeze_And_Append (Equivalent_Type (E), Loc, Result); Freeze_And_Append (Equivalent_Type (E), Loc, Result);
end if; end if;
......
gcc/ada/sem_ch3.adb
...@@ -1135,7 +1135,27 @@ package body Sem_Ch3 is ...@@ -1135,7 +1135,27 @@ package body Sem_Ch3 is
(T => Typ, (T => Typ,
Related_Nod => T_Def, Related_Nod => T_Def,
Scope_Id => Current_Scope)); Scope_Id => Current_Scope));
else else
if From_With_Type (Typ) then
Error_Msg_NE
("illegal use of incomplete type&",
Result_Definition (T_Def), Typ);
elsif Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
then
if Ekind (Typ) = E_Incomplete_Type then
Append_Elmt (Desig_Type, Private_Dependents (Typ));
elsif Is_Class_Wide_Type (Typ)
and then Ekind (Etype (Typ)) = E_Incomplete_Type
then
Append_Elmt
(Desig_Type, Private_Dependents (Etype (Typ)));
end if;
end if;
Set_Etype (Desig_Type, Typ); Set_Etype (Desig_Type, Typ);
end if; end if;
end; end;
......
gcc/ada/sem_ch6.adb
...@@ -7716,7 +7716,8 @@ package body Sem_Ch6 is ...@@ -7716,7 +7716,8 @@ package body Sem_Ch6 is
-- primitive operations, as long as their completion is -- primitive operations, as long as their completion is
-- in the same declarative part. If in the private part -- in the same declarative part. If in the private part
-- this means that the type cannot be a Taft-amendment type. -- this means that the type cannot be a Taft-amendment type.
-- Check is done on package exit. -- Check is done on package exit. For access to subprograms,
-- the use is legal for Taft-amendment types.
if Is_Tagged_Type (Formal_Type) then if Is_Tagged_Type (Formal_Type) then
if Ekind (Scope (Current_Scope)) = E_Package if Ekind (Scope (Current_Scope)) = E_Package
...@@ -7724,10 +7725,15 @@ package body Sem_Ch6 is ...@@ -7724,10 +7725,15 @@ package body Sem_Ch6 is
and then not From_With_Type (Formal_Type) and then not From_With_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type)
then then
if not Nkind_In
(Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
Append_Elmt Append_Elmt
(Current_Scope, (Current_Scope,
Private_Dependents (Base_Type (Formal_Type))); Private_Dependents (Base_Type (Formal_Type)));
end if; end if;
end if;
-- Special handling of Value_Type for CIL case -- Special handling of Value_Type for CIL case
......
gcc/ada/sem_ch7.adb
...@@ -25,8 +25,8 @@ ...@@ -25,8 +25,8 @@
-- This package contains the routines to process package specifications and -- This package contains the routines to process package specifications and
-- bodies. The most important semantic aspects of package processing are the -- bodies. The most important semantic aspects of package processing are the
-- handling of private and full declarations, and the construction of -- handling of private and full declarations, and the construction of dispatch
-- dispatch tables for tagged types. -- tables for tagged types.
with Atree; use Atree; with Atree; use Atree;
with Debug; use Debug; with Debug; use Debug;
...@@ -102,9 +102,9 @@ package body Sem_Ch7 is ...@@ -102,9 +102,9 @@ package body Sem_Ch7 is
-- before other body declarations. -- before other body declarations.
procedure Install_Package_Entity (Id : Entity_Id); procedure Install_Package_Entity (Id : Entity_Id);
-- Supporting procedure for Install_{Visible,Private}_Declarations. -- Supporting procedure for Install_{Visible,Private}_Declarations. Places
-- Places one entity on its visibility chain, and recurses on the visible -- one entity on its visibility chain, and recurses on the visible part if
-- part if the entity is an inner package. -- the entity is an inner package.
function Is_Private_Base_Type (E : Entity_Id) return Boolean; function Is_Private_Base_Type (E : Entity_Id) return Boolean;
-- True for a private type that is not a subtype -- True for a private type that is not a subtype
...@@ -144,10 +144,10 @@ package body Sem_Ch7 is ...@@ -144,10 +144,10 @@ package body Sem_Ch7 is
Pack_Decl : Node_Id; Pack_Decl : Node_Id;
procedure Install_Composite_Operations (P : Entity_Id); procedure Install_Composite_Operations (P : Entity_Id);
-- Composite types declared in the current scope may depend on -- Composite types declared in the current scope may depend on types
-- types that were private at the point of declaration, and whose -- that were private at the point of declaration, and whose full view
-- full view is now in scope. Indicate that the corresponding -- is now in scope. Indicate that the corresponding operations on the
-- operations on the composite type are available. -- composite type are available.
---------------------------------- ----------------------------------
-- Install_Composite_Operations -- -- Install_Composite_Operations --
...@@ -175,12 +175,12 @@ package body Sem_Ch7 is ...@@ -175,12 +175,12 @@ package body Sem_Ch7 is
-- Start of processing for Analyze_Package_Body -- Start of processing for Analyze_Package_Body
begin begin
-- Find corresponding package specification, and establish the -- Find corresponding package specification, and establish the current
-- current scope. The visible defining entity for the package is the -- scope. The visible defining entity for the package is the defining
-- defining occurrence in the spec. On exit from the package body, all -- occurrence in the spec. On exit from the package body, all body
-- body declarations are attached to the defining entity for the body, -- declarations are attached to the defining entity for the body, but
-- but the later is never used for name resolution. In this fashion -- the later is never used for name resolution. In this fashion there
-- there is only one visible entity that denotes the package. -- is only one visible entity that denotes the package.
if Debug_Flag_C then if Debug_Flag_C then
Write_Str ("==== Compiling package body "); Write_Str ("==== Compiling package body ");
...@@ -190,15 +190,15 @@ package body Sem_Ch7 is ...@@ -190,15 +190,15 @@ package body Sem_Ch7 is
Write_Eol; Write_Eol;
end if; end if;
-- Set Body_Id. Note that this Will be reset to point to the -- Set Body_Id. Note that this Will be reset to point to the generic
-- generic copy later on in the generic case. -- copy later on in the generic case.
Body_Id := Defining_Entity (N); Body_Id := Defining_Entity (N);
if Present (Corresponding_Spec (N)) then if Present (Corresponding_Spec (N)) then
-- Body is body of package instantiation. Corresponding spec -- Body is body of package instantiation. Corresponding spec has
-- has already been set. -- already been set.
Spec_Id := Corresponding_Spec (N); Spec_Id := Corresponding_Spec (N);
Pack_Decl := Unit_Declaration_Node (Spec_Id); Pack_Decl := Unit_Declaration_Node (Spec_Id);
...@@ -257,8 +257,8 @@ package body Sem_Ch7 is ...@@ -257,8 +257,8 @@ package body Sem_Ch7 is
if Ekind (Spec_Id) = E_Generic_Package then if Ekind (Spec_Id) = E_Generic_Package then
-- Disable expansion and perform semantic analysis on copy. -- Disable expansion and perform semantic analysis on copy. The
-- The unannotated body will be used in all instantiations. -- unannotated body will be used in all instantiations.
Body_Id := Defining_Entity (N); Body_Id := Defining_Entity (N);
Set_Ekind (Body_Id, E_Package_Body); Set_Ekind (Body_Id, E_Package_Body);
...@@ -270,23 +270,23 @@ package body Sem_Ch7 is ...@@ -270,23 +270,23 @@ package body Sem_Ch7 is
New_N := Copy_Generic_Node (N, Empty, Instantiating => False); New_N := Copy_Generic_Node (N, Empty, Instantiating => False);
Rewrite (N, New_N); Rewrite (N, New_N);
-- Update Body_Id to point to the copied node for the remainder -- Update Body_Id to point to the copied node for the remainder of
-- of the processing. -- the processing.
Body_Id := Defining_Entity (N); Body_Id := Defining_Entity (N);
Start_Generic; Start_Generic;
end if; end if;
-- The Body_Id is that of the copied node in the generic case, the -- The Body_Id is that of the copied node in the generic case, the
-- current node otherwise. Note that N was rewritten above, so we -- current node otherwise. Note that N was rewritten above, so we must
-- must be sure to get the latest Body_Id value. -- be sure to get the latest Body_Id value.
Set_Ekind (Body_Id, E_Package_Body); Set_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id); Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id); Set_Spec_Entity (Body_Id, Spec_Id);
-- Defining name for the package body is not a visible entity: Only -- Defining name for the package body is not a visible entity: Only the
-- the defining name for the declaration is visible. -- defining name for the declaration is visible.
Set_Etype (Body_Id, Standard_Void_Type); Set_Etype (Body_Id, Standard_Void_Type);
Set_Scope (Body_Id, Scope (Spec_Id)); Set_Scope (Body_Id, Scope (Spec_Id));
...@@ -340,7 +340,7 @@ package body Sem_Ch7 is ...@@ -340,7 +340,7 @@ package body Sem_Ch7 is
Inspect_Deferred_Constant_Completion (Declarations (N)); Inspect_Deferred_Constant_Completion (Declarations (N));
end if; end if;
-- Analyze_Declarations has caused freezing of all types; now generate -- Analyze_Declarations has caused freezing of all types. Now generate
-- bodies for RACW primitives and stream attributes, if any. -- bodies for RACW primitives and stream attributes, if any.
if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then if Ekind (Spec_Id) = E_Package and then Has_RACW (Spec_Id) then
...@@ -416,9 +416,8 @@ package body Sem_Ch7 is ...@@ -416,9 +416,8 @@ package body Sem_Ch7 is
Set_Is_Potentially_Use_Visible (E, False); Set_Is_Potentially_Use_Visible (E, False);
Set_Is_Hidden (E); Set_Is_Hidden (E);
-- Child units may appear on the entity list (for example if -- Child units may appear on the entity list (e.g. if they appear
-- they appear in the context of a subunit) but they are not -- in the context of a subunit) but they are not body entities.
-- body entities.
if not Is_Child_Unit (E) then if not Is_Child_Unit (E) then
Set_Is_Package_Body_Entity (E); Set_Is_Package_Body_Entity (E);
...@@ -444,9 +443,9 @@ package body Sem_Ch7 is ...@@ -444,9 +443,9 @@ package body Sem_Ch7 is
-- following loop runs backwards from the end of the entities of the -- following loop runs backwards from the end of the entities of the
-- package body making these entities invisible until we reach a -- package body making these entities invisible until we reach a
-- referencer, i.e. a declaration that could reference a previous -- referencer, i.e. a declaration that could reference a previous
-- declaration, a generic body or an inlined body, or a stub (which -- declaration, a generic body or an inlined body, or a stub (which may
-- may contain either of these). This is of course an approximation, -- contain either of these). This is of course an approximation, but it
-- but it is conservative and definitely correct. -- is conservative and definitely correct.
-- We only do this at the outer (library) level non-generic packages. -- We only do this at the outer (library) level non-generic packages.
-- The reason is simply to cut down on the number of external symbols -- The reason is simply to cut down on the number of external symbols
...@@ -464,16 +463,15 @@ package body Sem_Ch7 is ...@@ -464,16 +463,15 @@ package body Sem_Ch7 is
Outer : Boolean) Outer : Boolean)
return Boolean; return Boolean;
-- Traverse the given list of declarations in reverse order. -- Traverse the given list of declarations in reverse order.
-- Return True as soon as a referencer is reached. Return -- Return True as soon as a referencer is reached. Return False if
-- False if none is found. The Outer parameter is True for -- none is found. The Outer parameter is True for the outer level
-- the outer level call, and False for inner level calls for -- call, and False for inner level calls for nested packages. If
-- nested packages. If Outer is True, then any entities up -- Outer is True, then any entities up to the point of hitting a
-- to the point of hitting a referencer get their Is_Public -- referencer get their Is_Public flag cleared, so that the
-- flag cleared, so that the entities will be treated as -- entities will be treated as static entities in the C sense, and
-- static entities in the C sense, and need not have fully -- need not have fully qualified names. For inner levels, we need
-- qualified names. For inner levels, we need all names to -- all names to be fully qualified to deal with the same name
-- be fully qualified to deal with the same name appearing -- appearing in parallel packages (right now this is tied to their
-- in parallel packages (right now this is tied to their
-- being external). -- being external).
-------------------- --------------------
...@@ -512,10 +510,10 @@ package body Sem_Ch7 is ...@@ -512,10 +510,10 @@ package body Sem_Ch7 is
-- Note that we test Has_Pragma_Inline here rather -- Note that we test Has_Pragma_Inline here rather
-- than Is_Inlined. We are compiling this for a -- than Is_Inlined. We are compiling this for a
-- client, and it is the client who will decide -- client, and it is the client who will decide if
-- if actual inlining should occur, so we need to -- actual inlining should occur, so we need to assume
-- assume that the procedure could be inlined for -- that the procedure could be inlined for the purpose
-- the purpose of accessing global entities. -- of accessing global entities.
if Has_Pragma_Inline (E) then if Has_Pragma_Inline (E) then
return True; return True;
...@@ -542,20 +540,19 @@ package body Sem_Ch7 is ...@@ -542,20 +540,19 @@ package body Sem_Ch7 is
then then
E := Corresponding_Spec (D); E := Corresponding_Spec (D);
-- Generic package body is a referencer. It would -- Generic package body is a referencer. It would seem
-- seem that we only have to consider generics that -- that we only have to consider generics that can be
-- can be exported, i.e. where the corresponding spec -- exported, i.e. where the corresponding spec is the
-- is the spec of the current package, but because of -- spec of the current package, but because of nested
-- nested instantiations, a fully private generic -- instantiations, a fully private generic body may
-- body may export other private body entities. -- export other private body entities.
if Is_Generic_Unit (E) then if Is_Generic_Unit (E) then
return True; return True;
-- For non-generic package body, recurse into body -- For non-generic package body, recurse into body unless
-- unless this is an instance, we ignore instances -- this is an instance, we ignore instances since they
-- since they cannot have references that affect -- cannot have references that affect outer entities.
-- outer entities.
elsif not Is_Generic_Instance (E) then elsif not Is_Generic_Instance (E) then
if Has_Referencer if Has_Referencer
...@@ -583,10 +580,10 @@ package body Sem_Ch7 is ...@@ -583,10 +580,10 @@ package body Sem_Ch7 is
end if; end if;
end if; end if;
-- Objects and exceptions need not be public if we have -- Objects and exceptions need not be public if we have not
-- not encountered a referencer so far. We only reset -- encountered a referencer so far. We only reset the flag
-- the flag for outer level entities that are not -- for outer level entities that are not imported/exported,
-- imported/exported, and which have no interface name. -- and which have no interface name.
elsif Nkind_In (K, N_Object_Declaration, elsif Nkind_In (K, N_Object_Declaration,
N_Exception_Declaration, N_Exception_Declaration,
...@@ -623,10 +620,10 @@ package body Sem_Ch7 is ...@@ -623,10 +620,10 @@ package body Sem_Ch7 is
end if; end if;
-- If expander is not active, then here is where we turn off the -- If expander is not active, then here is where we turn off the
-- In_Package_Body flag, otherwise it is turned off at the end of -- In_Package_Body flag, otherwise it is turned off at the end of the
-- the corresponding expansion routine. If this is an instance body, -- corresponding expansion routine. If this is an instance body, we need
-- we need to qualify names of local entities, because the body may -- to qualify names of local entities, because the body may have been
-- have been compiled as a preliminary to another instantiation. -- compiled as a preliminary to another instantiation.
if not Expander_Active then if not Expander_Active then
Set_In_Package_Body (Spec_Id, False); Set_In_Package_Body (Spec_Id, False);
...@@ -692,9 +689,9 @@ package body Sem_Ch7 is ...@@ -692,9 +689,9 @@ package body Sem_Ch7 is
Body_Required := Unit_Requires_Body (Id); Body_Required := Unit_Requires_Body (Id);
-- When this spec does not require an explicit body, we know that -- When this spec does not require an explicit body, we know that there
-- there are no entities requiring completion in the language sense; -- are no entities requiring completion in the language sense; we call
-- we call Check_Completion here only to ensure that any nested package -- Check_Completion here only to ensure that any nested package
-- declaration that requires an implicit body gets one. (In the case -- declaration that requires an implicit body gets one. (In the case
-- where a body is required, Check_Completion is called at the end of -- where a body is required, Check_Completion is called at the end of
-- the body's declarative part.) -- the body's declarative part.)
...@@ -734,8 +731,8 @@ package body Sem_Ch7 is ...@@ -734,8 +731,8 @@ package body Sem_Ch7 is
-- Analyze_Package_Specification -- -- Analyze_Package_Specification --
----------------------------------- -----------------------------------
-- Note that this code is shared for the analysis of generic package -- Note that this code is shared for the analysis of generic package specs
-- specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details). -- (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
procedure Analyze_Package_Specification (N : Node_Id) is procedure Analyze_Package_Specification (N : Node_Id) is
Id : constant Entity_Id := Defining_Entity (N); Id : constant Entity_Id := Defining_Entity (N);
...@@ -760,10 +757,10 @@ package body Sem_Ch7 is ...@@ -760,10 +757,10 @@ package body Sem_Ch7 is
-- visibility analysis for preconditions and postconditions in specs. -- visibility analysis for preconditions and postconditions in specs.
procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id); procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
-- Clears constant indications (Never_Set_In_Source, Constant_Value, -- Clears constant indications (Never_Set_In_Source, Constant_Value, and
-- and Is_True_Constant) on all variables that are entities of Id, -- Is_True_Constant) on all variables that are entities of Id, and on
-- and on the chain whose first element is FE. A recursive call is -- the chain whose first element is FE. A recursive call is made for all
-- made for all packages and generic packages. -- packages and generic packages.
procedure Generate_Parent_References; procedure Generate_Parent_References;
-- For a child unit, generate references to parent units, for -- For a child unit, generate references to parent units, for
...@@ -822,18 +819,17 @@ package body Sem_Ch7 is ...@@ -822,18 +819,17 @@ package body Sem_Ch7 is
E : Entity_Id; E : Entity_Id;
begin begin
-- Ignore package renamings, not interesting and they can -- Ignore package renamings, not interesting and they can cause self
-- cause self referential loops in the code below. -- referential loops in the code below.
if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
return; return;
end if; end if;
-- Note: in the loop below, the check for Next_Entity pointing -- Note: in the loop below, the check for Next_Entity pointing back
-- back to the package entity may seem odd, but it is needed, -- to the package entity may seem odd, but it is needed, because a
-- because a package can contain a renaming declaration to itself, -- package can contain a renaming declaration to itself, and such
-- and such renamings are generated automatically within package -- renamings are generated automatically within package instances.
-- instances.
E := FE; E := FE;
while Present (E) and then E /= Id loop while Present (E) and then E /= Id loop
...@@ -873,8 +869,8 @@ package body Sem_Ch7 is ...@@ -873,8 +869,8 @@ package body Sem_Ch7 is
elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body, elsif not Nkind_In (Unit (Cunit (Main_Unit)), N_Subprogram_Body,
N_Subunit) N_Subunit)
then then
-- If current unit is an ancestor of main unit, generate -- If current unit is an ancestor of main unit, generate a
-- a reference to its own parent. -- reference to its own parent.
declare declare
U : Node_Id; U : Node_Id;
...@@ -1065,11 +1061,11 @@ package body Sem_Ch7 is ...@@ -1065,11 +1061,11 @@ package body Sem_Ch7 is
Validate_RCI_Declarations (Id); Validate_RCI_Declarations (Id);
end if; end if;
-- Save global references in the visible declarations, before -- Save global references in the visible declarations, before installing
-- installing private declarations of parent unit if there is one, -- private declarations of parent unit if there is one, because the
-- because the privacy status of types defined in the parent will -- privacy status of types defined in the parent will change. This is
-- change. This is only relevant for generic child units, but is -- only relevant for generic child units, but is done in all cases for
-- done in all cases for uniformity. -- uniformity.
if Ekind (Id) = E_Generic_Package if Ekind (Id) = E_Generic_Package
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
...@@ -1360,8 +1356,8 @@ package body Sem_Ch7 is ...@@ -1360,8 +1356,8 @@ package body Sem_Ch7 is
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean; function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an -- Check whether an inherited subprogram is an operation of an untagged
-- untagged derived type. -- derived type.
--------------------- ---------------------
-- Is_Primitive_Of -- -- Is_Primitive_Of --
...@@ -1371,9 +1367,9 @@ package body Sem_Ch7 is ...@@ -1371,9 +1367,9 @@ package body Sem_Ch7 is
Formal : Entity_Id; Formal : Entity_Id;
begin begin
-- If the full view is a scalar type, the type is the anonymous -- If the full view is a scalar type, the type is the anonymous base
-- base type, but the operation mentions the first subtype, so -- type, but the operation mentions the first subtype, so check the
-- check the signature against the base type. -- signature against the base type.
if Base_Type (Etype (S)) = Base_Type (T) then if Base_Type (Etype (S)) = Base_Type (T) then
return True; return True;
...@@ -1409,10 +1405,10 @@ package body Sem_Ch7 is ...@@ -1409,10 +1405,10 @@ package body Sem_Ch7 is
E := First_Entity (Id); E := First_Entity (Id);
while Present (E) loop while Present (E) loop
-- If the entity is a nonprivate type extension whose parent -- If the entity is a nonprivate type extension whose parent type
-- type is declared in an open scope, then the type may have -- is declared in an open scope, then the type may have inherited
-- inherited operations that now need to be made visible. -- operations that now need to be made visible. Ditto if the entity
-- Ditto if the entity is a formal derived type in a child unit. -- is a formal derived type in a child unit.
if ((Is_Derived_Type (E) and then not Is_Private_Type (E)) if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
or else or else
...@@ -1498,16 +1494,15 @@ package body Sem_Ch7 is ...@@ -1498,16 +1494,15 @@ package body Sem_Ch7 is
(Is_Dispatching_Operation (New_Op) (Is_Dispatching_Operation (New_Op)
and then Node (Last_Elmt (Op_List)) = New_Op); and then Node (Last_Elmt (Op_List)) = New_Op);
-- Substitute the new operation for the old one -- Substitute the new operation for the old one in the
-- in the type's primitive operations list. Since -- type's primitive operations list. Since the new
-- the new operation was also just added to the end -- operation was also just added to the end of list,
-- of list, the last element must be removed. -- the last element must be removed.
-- (Question: is there a simpler way of declaring -- (Question: is there a simpler way of declaring the
-- the operation, say by just replacing the name -- operation, say by just replacing the name of the
-- of the earlier operation, reentering it in the -- earlier operation, reentering it in the in the symbol
-- in the symbol table (how?), and marking it as -- table (how?), and marking it as private???)
-- private???)
Replace_Elmt (Op_Elmt, New_Op); Replace_Elmt (Op_Elmt, New_Op);
Remove_Last_Elmt (Op_List); Remove_Last_Elmt (Op_List);
...@@ -1524,8 +1519,8 @@ package body Sem_Ch7 is ...@@ -1524,8 +1519,8 @@ package body Sem_Ch7 is
end if; end if;
else else
-- Non-tagged type, scan forward to locate -- Non-tagged type, scan forward to locate inherited hidden
-- inherited hidden operations. -- operations.
Prim_Op := Next_Entity (E); Prim_Op := Next_Entity (E);
while Present (Prim_Op) loop while Present (Prim_Op) loop
...@@ -1581,8 +1576,8 @@ package body Sem_Ch7 is ...@@ -1581,8 +1576,8 @@ package body Sem_Ch7 is
Next2 := Next_Entity (Full_Id); Next2 := Next_Entity (Full_Id);
H2 := Homonym (Full_Id); H2 := Homonym (Full_Id);
-- Reset full declaration pointer to reflect the switched entities -- Reset full declaration pointer to reflect the switched entities and
-- and readjust the next entity chains. -- readjust the next entity chains.
Exchange_Entities (Id, Full_Id); Exchange_Entities (Id, Full_Id);
...@@ -1625,13 +1620,13 @@ package body Sem_Ch7 is ...@@ -1625,13 +1620,13 @@ package body Sem_Ch7 is
Full : Entity_Id; Full : Entity_Id;
begin begin
-- First exchange declarations for private types, so that the -- First exchange declarations for private types, so that the full
-- full declaration is visible. For each private type, we check -- declaration is visible. For each private type, we check its
-- its Private_Dependents list and also exchange any subtypes of -- Private_Dependents list and also exchange any subtypes of or derived
-- or derived types from it. Finally, if this is a Taft amendment -- types from it. Finally, if this is a Taft amendment type, the
-- type, the incomplete declaration is irrelevant, and we want to -- incomplete declaration is irrelevant, and we want to link the
-- link the eventual full declaration with the original private -- eventual full declaration with the original private one so we also
-- one so we also skip the exchange. -- skip the exchange.
Id := First_Entity (P); Id := First_Entity (P);
while Present (Id) and then Id /= First_Private_Entity (P) loop while Present (Id) and then Id /= First_Private_Entity (P) loop
...@@ -1659,12 +1654,12 @@ package body Sem_Ch7 is ...@@ -1659,12 +1654,12 @@ package body Sem_Ch7 is
-- can only happen in a package nested within a child package, -- can only happen in a package nested within a child package,
-- when the parent type is defined in the parent unit. At this -- when the parent type is defined in the parent unit. At this
-- point the current type is not private either, and we have to -- point the current type is not private either, and we have to
-- install the underlying full view, which is now visible. -- install the underlying full view, which is now visible. Save
-- Save the current full view as well, so that all views can -- the current full view as well, so that all views can be
-- be restored on exit. It may seem that after compiling the -- restored on exit. It may seem that after compiling the child
-- child body there are not environments to restore, but the -- body there are not environments to restore, but the back-end
-- back-end expects those links to be valid, and freeze nodes -- expects those links to be valid, and freeze nodes depend on
-- depend on them. -- them.
if No (Full_View (Full)) if No (Full_View (Full))
and then Present (Underlying_Full_View (Full)) and then Present (Underlying_Full_View (Full))
...@@ -1686,8 +1681,8 @@ package body Sem_Ch7 is ...@@ -1686,8 +1681,8 @@ package body Sem_Ch7 is
Priv := Node (Priv_Elmt); Priv := Node (Priv_Elmt);
-- Before the exchange, verify that the presence of the -- Before the exchange, verify that the presence of the
-- Full_View field. It will be empty if the entity -- Full_View field. It will be empty if the entity has already
-- has already been installed due to a previous call. -- been installed due to a previous call.
if Present (Full_View (Priv)) if Present (Full_View (Priv))
and then Is_Visible_Dependent (Priv) and then Is_Visible_Dependent (Priv)
...@@ -1772,8 +1767,7 @@ package body Sem_Ch7 is ...@@ -1772,8 +1767,7 @@ package body Sem_Ch7 is
S : constant Entity_Id := Scope (Dep); S : constant Entity_Id := Scope (Dep);
begin begin
-- Renamings created for actual types have the visibility of the -- Renamings created for actual types have the visibility of the actual
-- actual.
if Ekind (S) = E_Package if Ekind (S) = E_Package
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
...@@ -1785,9 +1779,9 @@ package body Sem_Ch7 is ...@@ -1785,9 +1779,9 @@ package body Sem_Ch7 is
elsif not (Is_Derived_Type (Dep)) elsif not (Is_Derived_Type (Dep))
and then Is_Derived_Type (Full_View (Dep)) and then Is_Derived_Type (Full_View (Dep))
then then
-- When instantiating a package body, the scope stack is empty, -- When instantiating a package body, the scope stack is empty, so
-- so check instead whether the dependent type is defined in -- check instead whether the dependent type is defined in the same
-- the same scope as the instance itself. -- scope as the instance itself.
return In_Open_Scopes (S) return In_Open_Scopes (S)
or else (Is_Generic_Instance (Current_Scope) or else (Is_Generic_Instance (Current_Scope)
...@@ -1856,8 +1850,8 @@ package body Sem_Ch7 is ...@@ -1856,8 +1850,8 @@ package body Sem_Ch7 is
No (Discriminant_Specifications (N)) No (Discriminant_Specifications (N))
and then not Unknown_Discriminants_Present (N)); and then not Unknown_Discriminants_Present (N));
-- Set tagged flag before processing discriminants, to catch -- Set tagged flag before processing discriminants, to catch illegal
-- illegal usage. -- usage.
Set_Is_Tagged_Type (Id, Tagged_Present (Def)); Set_Is_Tagged_Type (Id, Tagged_Present (Def));
...@@ -1900,8 +1894,8 @@ package body Sem_Ch7 is ...@@ -1900,8 +1894,8 @@ package body Sem_Ch7 is
Priv_Sub : Entity_Id; Priv_Sub : Entity_Id;
procedure Preserve_Full_Attributes (Priv, Full : Entity_Id); procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
-- Copy to the private declaration the attributes of the full view -- Copy to the private declaration the attributes of the full view that
-- that need to be available for the partial view also. -- need to be available for the partial view also.
function Type_In_Use (T : Entity_Id) return Boolean; function Type_In_Use (T : Entity_Id) return Boolean;
-- Check whether type or base type appear in an active use_type clause -- Check whether type or base type appear in an active use_type clause
...@@ -1951,8 +1945,8 @@ package body Sem_Ch7 is ...@@ -1951,8 +1945,8 @@ package body Sem_Ch7 is
then then
if Priv_Is_Base_Type then if Priv_Is_Base_Type then
-- Ada 2005 (AI-345): The full view of a type implementing -- Ada 2005 (AI-345): The full view of a type implementing an
-- an interface can be a task type. -- interface can be a task type.
-- type T is new I with private; -- type T is new I with private;
-- private -- private
...@@ -1984,8 +1978,8 @@ package body Sem_Ch7 is ...@@ -1984,8 +1978,8 @@ package body Sem_Ch7 is
if Is_Tagged_Type (Priv) then if Is_Tagged_Type (Priv) then
-- If the type is tagged, the tag itself must be available -- If the type is tagged, the tag itself must be available on
-- on the partial view, for expansion purposes. -- the partial view, for expansion purposes.
Set_First_Entity (Priv, First_Entity (Full)); Set_First_Entity (Priv, First_Entity (Full));
...@@ -2156,8 +2150,8 @@ package body Sem_Ch7 is ...@@ -2156,8 +2150,8 @@ package body Sem_Ch7 is
end if; end if;
-- Make private entities invisible and exchange full and private -- Make private entities invisible and exchange full and private
-- declarations for private types. Id is now the first private -- declarations for private types. Id is now the first private entity
-- entity in the package. -- in the package.
while Present (Id) loop while Present (Id) loop
if Debug_Flag_E then if Debug_Flag_E then
...@@ -2178,10 +2172,10 @@ package body Sem_Ch7 is ...@@ -2178,10 +2172,10 @@ package body Sem_Ch7 is
then then
Full := Full_View (Id); Full := Full_View (Id);
-- If the partial view is not declared in the visible part -- If the partial view is not declared in the visible part of the
-- of the package (as is the case when it is a type derived -- package (as is the case when it is a type derived from some
-- from some other private type in the private part of the -- other private type in the private part of the current package),
-- current package), no exchange takes place. -- no exchange takes place.
if No (Parent (Id)) if No (Parent (Id))
or else List_Containing (Parent (Id)) or else List_Containing (Parent (Id))
...@@ -2192,10 +2186,10 @@ package body Sem_Ch7 is ...@@ -2192,10 +2186,10 @@ package body Sem_Ch7 is
-- The entry in the private part points to the full declaration, -- The entry in the private part points to the full declaration,
-- which is currently visible. Exchange them so only the private -- which is currently visible. Exchange them so only the private
-- type declaration remains accessible, and link private and -- type declaration remains accessible, and link private and full
-- full declaration in the opposite direction. Before the actual -- declaration in the opposite direction. Before the actual
-- exchange, we copy back attributes of the full view that -- exchange, we copy back attributes of the full view that must
-- must be available to the partial view too. -- be available to the partial view too.
Preserve_Full_Attributes (Id, Full); Preserve_Full_Attributes (Id, Full);
...@@ -2213,10 +2207,10 @@ package body Sem_Ch7 is ...@@ -2213,10 +2207,10 @@ package body Sem_Ch7 is
-- Swap out the subtypes and derived types of Id that were -- Swap out the subtypes and derived types of Id that were
-- compiled in this scope, or installed previously by -- compiled in this scope, or installed previously by
-- Install_Private_Declarations. -- Install_Private_Declarations.
-- Before we do the swap, we verify the presence of the
-- Full_View field which may be empty due to a swap by -- Before we do the swap, we verify the presence of the Full_View
-- a previous call to End_Package_Scope (e.g. from the -- field which may be empty due to a swap by a previous call to
-- freezing mechanism). -- End_Package_Scope (e.g. from the freezing mechanism).
while Present (Priv_Elmt) loop while Present (Priv_Elmt) loop
Priv_Sub := Node (Priv_Elmt); Priv_Sub := Node (Priv_Elmt);
...@@ -2244,10 +2238,11 @@ package body Sem_Ch7 is ...@@ -2244,10 +2238,11 @@ package body Sem_Ch7 is
Exchange_Declarations (Id); Exchange_Declarations (Id);
-- If we have installed an underlying full view for a type -- If we have installed an underlying full view for a type derived
-- derived from a private type in a child unit, restore the -- from a private type in a child unit, restore the proper views
-- proper views of private and full view. See corresponding -- of private and full view. See corresponding code in
-- code in Install_Private_Declarations. -- Install_Private_Declarations.
-- After the exchange, Full denotes the private type in the -- After the exchange, Full denotes the private type in the
-- visible part of the package. -- visible part of the package.
...@@ -2264,9 +2259,8 @@ package body Sem_Ch7 is ...@@ -2264,9 +2259,8 @@ package body Sem_Ch7 is
and then Comes_From_Source (Id) and then Comes_From_Source (Id)
and then No (Full_View (Id)) and then No (Full_View (Id))
then then
-- Mark Taft amendment types. Verify that there are no primitive
-- Mark Taft amendment types. Verify that there are no -- operations declared for the type (3.10.1 (9)).
-- primitive operations declared for the type (3.10.1 (9)).
Set_Has_Completion_In_Body (Id); Set_Has_Completion_In_Body (Id);
...@@ -2278,10 +2272,25 @@ package body Sem_Ch7 is ...@@ -2278,10 +2272,25 @@ package body Sem_Ch7 is
Elmt := First_Elmt (Private_Dependents (Id)); Elmt := First_Elmt (Private_Dependents (Id));
while Present (Elmt) loop while Present (Elmt) loop
Subp := Node (Elmt); Subp := Node (Elmt);
if Is_Overloadable (Subp) then if Is_Overloadable (Subp) then
Error_Msg_NE Error_Msg_NE
("type& must be completed in the private part", ("type& must be completed in the private part",
Parent (Subp), Id); Parent (Subp), Id);
-- The return type of an access_to_function cannot be a
-- Taft-amendment type.
elsif Ekind (Subp) = E_Subprogram_Type then
if Etype (Subp) = Id
or else
(Is_Class_Wide_Type (Etype (Subp))
and then Etype (Etype (Subp)) = Id)
then
Error_Msg_NE
("type& must be completed in the private part",
Associated_Node_For_Itype (Subp), Id);
end if;
end if; end if;
Next_Elmt (Elmt); Next_Elmt (Elmt);
...@@ -2309,9 +2318,9 @@ package body Sem_Ch7 is ...@@ -2309,9 +2318,9 @@ package body Sem_Ch7 is
E : Entity_Id; E : Entity_Id;
begin begin
-- Imported entity never requires body. Right now, only -- Imported entity never requires body. Right now, only subprograms can
-- subprograms can be imported, but perhaps in the future -- be imported, but perhaps in the future we will allow import of
-- we will allow import of packages. -- packages.
if Is_Imported (P) then if Is_Imported (P) then
return False; return False;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment